Commit 61171aef authored by Heiko Becker's avatar Heiko Becker

Merge branch 'fma_proofs_merge' into 'certificates'

Fma proofs merge

See merge request AVA/daisy!170
parents 13ae6d87 c14fe5f4
...@@ -258,6 +258,75 @@ Proof. ...@@ -258,6 +258,75 @@ Proof.
apply Rabs_pos. apply Rabs_pos.
Qed. Qed.
Lemma fma_abs_err_bounded (e1:exp Q) (e1R:R) (e1F:R) (e2:exp Q) (e2R:R) (e2F:R)
(e3:exp Q) (e3R:R) (e3F:R)
(vR:R) (vF:R) (E1 E2:env) (m m1 m2 m3:mType) defVars:
eval_exp E1 (toRMap defVars) (toREval (toRExp e1)) e1R M0 ->
eval_exp E2 defVars (toRExp e1) e1F m1->
eval_exp E1 (toRMap defVars) (toREval (toRExp e2)) e2R M0 ->
eval_exp E2 defVars (toRExp e2) e2F m2 ->
eval_exp E1 (toRMap defVars) (toREval (toRExp e3)) e3R M0 ->
eval_exp E2 defVars (toRExp e3) e3F m3->
eval_exp E1 (toRMap defVars) (toREval (Fma (toRExp e1) (toRExp e2) (toRExp e3))) vR M0 ->
eval_exp (updEnv 3 e3F (updEnv 2 e2F (updEnv 1 e1F emptyEnv)))
(updDefVars 3 m3 (updDefVars 2 m2 (updDefVars 1 m1 defVars)))
(Fma (Var R 1) (Var R 2) (Var R 3)) vF m ->
(Rabs (vR - vF) <= Rabs ((e1R - e1F) + (e2R * e3R - e2F * e3F)) + Rabs (e1F + e2F * e3F) * (Q2R (mTypeToQ m)))%R.
Proof.
intros e1_real e1_float e2_real e2_float e3_real e3_float fma_real fma_float.
inversion fma_real; subst;
assert (m0 = M0) by (eapply toRMap_eval_M0; eauto).
assert (m4 = M0) by (eapply toRMap_eval_M0; eauto).
assert (m5 = M0) by (eapply toRMap_eval_M0; eauto).
subst; simpl in H3; rewrite Q2R0_is_0 in H3; auto.
rewrite delta_0_deterministic in fma_real; auto.
rewrite delta_0_deterministic; auto.
unfold evalFma in *; simpl in *.
clear delta H3.
rewrite (meps_0_deterministic (toRExp e1) H5 e1_real);
rewrite (meps_0_deterministic (toRExp e2) H6 e2_real);
rewrite (meps_0_deterministic (toRExp e3) H7 e3_real).
rewrite (meps_0_deterministic (toRExp e1) H5 e1_real) in fma_real.
rewrite (meps_0_deterministic (toRExp e2) H6 e2_real) in fma_real.
rewrite (meps_0_deterministic (toRExp e3) H7 e3_real) in fma_real.
clear H5 H6 v1 v2 v3 H7 H2.
inversion fma_float; subst.
unfold evalFma in *.
unfold perturb; simpl.
inversion H3; subst; inversion H6; subst; inversion H7; subst.
unfold updEnv in *; simpl in *.
inversion H5; inversion H1; inversion H9; subst.
clear fma_float H7 fma_real e1_real e1_float e2_real e2_float e3_real e3_float H6 H1 H5 H9 H3 H0 H4 H8.
repeat rewrite Rmult_plus_distr_l.
rewrite Rmult_1_r.
rewrite Rsub_eq_Ropp_Rplus.
rewrite Ropp_plus_distr.
rewrite <- Rplus_assoc.
setoid_rewrite <- Rsub_eq_Ropp_Rplus at 2.
rewrite Rsub_eq_Ropp_Rplus.
rewrite Rsub_eq_Ropp_Rplus.
rewrite Rsub_eq_Ropp_Rplus.
rewrite <- Rplus_assoc.
setoid_rewrite Rplus_comm at 8.
rewrite <- Rplus_assoc.
setoid_rewrite Rplus_comm at 9.
rewrite Rplus_assoc.
setoid_rewrite Rplus_assoc at 2.
rewrite <- Rplus_assoc.
rewrite <- Rsub_eq_Ropp_Rplus.
rewrite <- Rsub_eq_Ropp_Rplus.
rewrite <- Ropp_plus_distr.
rewrite <- Rsub_eq_Ropp_Rplus.
eapply Rle_trans.
eapply Rabs_triang.
eapply Rplus_le_compat_l.
rewrite Rabs_Ropp.
repeat rewrite Rabs_mult.
eapply Rmult_le_compat_l; auto.
apply Rabs_pos.
Qed.
Lemma err_prop_inversion_pos_real nF nR err elo ehi Lemma err_prop_inversion_pos_real nF nR err elo ehi
(float_iv_pos : (0 < elo - err)%R) (float_iv_pos : (0 < elo - err)%R)
(real_iv_pos : (0 < elo)%R) (real_iv_pos : (0 < elo)%R)
......
This diff is collapsed.
...@@ -98,6 +98,9 @@ Definition evalUnop (o:unop) (v:R):= ...@@ -98,6 +98,9 @@ Definition evalUnop (o:unop) (v:R):=
|Inv => (/ v)%R |Inv => (/ v)%R
end . end .
Definition evalFma (v1:R) (v2:R) (v3:R):=
evalBinop Plus v1 (evalBinop Mult v2 v3).
(** (**
Define expressions parametric over some value type V. Define expressions parametric over some value type V.
Will ease reasoning about different instantiations later. Will ease reasoning about different instantiations later.
...@@ -107,6 +110,7 @@ Inductive exp (V:Type): Type := ...@@ -107,6 +110,7 @@ Inductive exp (V:Type): Type :=
| Const: mType -> V -> exp V | Const: mType -> V -> exp V
| Unop: unop -> exp V -> exp V | Unop: unop -> exp V -> exp V
| Binop: binop -> exp V -> exp V -> exp V | Binop: binop -> exp V -> exp V -> exp V
| Fma: exp V -> exp V -> exp V -> exp V
| Downcast: mType -> exp V -> exp V. | Downcast: mType -> exp V -> exp V.
(** (**
...@@ -122,6 +126,8 @@ Fixpoint expEq (e1:exp Q) (e2:exp Q) := ...@@ -122,6 +126,8 @@ Fixpoint expEq (e1:exp Q) (e2:exp Q) :=
(unopEq o1 o2) && (expEq e11 e22) (unopEq o1 o2) && (expEq e11 e22)
| Binop o1 e11 e12, Binop o2 e21 e22 => | Binop o1 e11 e12, Binop o2 e21 e22 =>
(binopEq o1 o2) && (expEq e11 e21) && (expEq e12 e22) (binopEq o1 o2) && (expEq e11 e21) && (expEq e12 e22)
| Fma e11 e12 e13, Fma e21 e22 e23 =>
(expEq e11 e21) && (expEq e12 e22) && (expEq e13 e23)
| Downcast m1 f1, Downcast m2 f2 => | Downcast m1 f1, Downcast m2 f2 =>
(mTypeEq m1 m2) && (expEq f1 f2) (mTypeEq m1 m2) && (expEq f1 f2)
| _, _ => false | _, _ => false
...@@ -136,6 +142,7 @@ Proof. ...@@ -136,6 +142,7 @@ Proof.
- apply Qeq_bool_iff; lra. - apply Qeq_bool_iff; lra.
- case u; auto. - case u; auto.
- case b; auto. - case b; auto.
- firstorder.
- apply mTypeEq_refl. - apply mTypeEq_refl.
Qed. Qed.
...@@ -156,6 +163,9 @@ Proof. ...@@ -156,6 +163,9 @@ Proof.
* destruct b; auto. * destruct b; auto.
* apply IHe1. * apply IHe1.
+ apply IHe2. + apply IHe2.
- f_equal.
+ f_equal; auto.
+ auto.
- f_equal. - f_equal.
+ apply mTypeEq_sym; auto. + apply mTypeEq_sym; auto.
+ apply IHe. + apply IHe.
...@@ -180,6 +190,9 @@ Proof. ...@@ -180,6 +190,9 @@ Proof.
rewrite binopEq_refl; simpl. rewrite binopEq_refl; simpl.
apply andb_true_iff. apply andb_true_iff.
split; [eapply IHe1; eauto | eapply IHe2; eauto]. split; [eapply IHe1; eauto | eapply IHe2; eauto].
- rewrite andb_true_iff.
rewrite andb_true_iff.
split; [split; [eapply IHe1; eauto | eapply IHe2; eauto] | eapply IHe3; eauto].
- rewrite mTypeEq_refl; simpl. - rewrite mTypeEq_refl; simpl.
eapply IHe; eauto. eapply IHe; eauto.
Qed. Qed.
...@@ -206,6 +219,7 @@ Module ExpOrderedType (V_ordered:OrderType) <: OrderType. ...@@ -206,6 +219,7 @@ Module ExpOrderedType (V_ordered:OrderType) <: OrderType.
if unopEq u1 u2 if unopEq u1 u2
then expCompare e1 e2 then expCompare e1 e2
else (if unopEq u1 Neg then Lt else Gt) else (if unopEq u1 Neg then Lt else Gt)
| Unop _ _, Fma _ _ _ => Lt
| Unop _ _, Binop _ _ _ => Lt | Unop _ _, Binop _ _ _ => Lt
| Unop _ _, Downcast _ _ => Lt | Unop _ _, Downcast _ _ => Lt
| Unop _ _, _ => Gt | Unop _ _, _ => Gt
...@@ -213,6 +227,7 @@ Module ExpOrderedType (V_ordered:OrderType) <: OrderType. ...@@ -213,6 +227,7 @@ Module ExpOrderedType (V_ordered:OrderType) <: OrderType.
if mTypeEq m1 m2 if mTypeEq m1 m2
then expCompare e1 e2 then expCompare e1 e2
else (if morePrecise m1 m2 then Lt else Gt) else (if morePrecise m1 m2 then Lt else Gt)
| Downcast _ _, Fma _ _ _ => Lt
| Downcast _ _, Binop _ _ _ => Lt | Downcast _ _, Binop _ _ _ => Lt
| Downcast _ _, _ => Gt | Downcast _ _, _ => Gt
| Binop b1 e11 e12, Binop b2 e21 e22 => | Binop b1 e11 e12, Binop b2 e21 e22 =>
...@@ -238,7 +253,19 @@ Module ExpOrderedType (V_ordered:OrderType) <: OrderType. ...@@ -238,7 +253,19 @@ Module ExpOrderedType (V_ordered:OrderType) <: OrderType.
end end
| _ => res | _ => res
end end
|_ , _ => Gt | Binop _ _ _, Fma _ _ _ => Lt
| Binop _ _ _, _ => Gt
| Fma e11 e12 e13, Fma e21 e22 e23 =>
match expCompare e11 e21 with
| Eq => match expCompare e12 e22 with
| Eq => expCompare e13 e23
| Lt => Lt
| Gt => Gt
end
| Lt => Lt
| Gt => Gt
end
| Fma _ _ _ , _ => Gt
end. end.
Lemma expCompare_refl e: expCompare e e = Eq. Lemma expCompare_refl e: expCompare e e = Eq.
...@@ -248,6 +275,7 @@ Module ExpOrderedType (V_ordered:OrderType) <: OrderType. ...@@ -248,6 +275,7 @@ Module ExpOrderedType (V_ordered:OrderType) <: OrderType.
- rewrite mTypeEq_refl. apply V_orderedFacts.compare_refl. - rewrite mTypeEq_refl. apply V_orderedFacts.compare_refl.
- rewrite unopEq_refl; auto. - rewrite unopEq_refl; auto.
- rewrite IHe1, IHe2. destruct b; auto. - rewrite IHe1, IHe2. destruct b; auto.
- now rewrite IHe1, IHe2, IHe3.
- rewrite mTypeEq_refl; auto. - rewrite mTypeEq_refl; auto.
Qed. Qed.
...@@ -295,6 +323,11 @@ Module ExpOrderedType (V_ordered:OrderType) <: OrderType. ...@@ -295,6 +323,11 @@ Module ExpOrderedType (V_ordered:OrderType) <: OrderType.
destruct (expCompare e1_1 e2_1) eqn:?; destruct (expCompare e1_1 e2_1) eqn:?;
destruct (expCompare e2_1 e3_1) eqn:?; destruct (expCompare e2_1 e3_1) eqn:?;
try congruence; try erewrite IHe1_1; eauto. try congruence; try erewrite IHe1_1; eauto.
- destruct (expCompare e1_1 e2_1) eqn:?;
destruct (expCompare e2_1 e3_1) eqn:?;
destruct (expCompare e1_2 e2_2) eqn:?;
destruct (expCompare e2_2 e3_2) eqn:?;
try congruence; try erewrite IHe1_1, IHe1_2; eauto.
- destruct (mTypeEq m m0) eqn:?; - destruct (mTypeEq m m0) eqn:?;
destruct (mTypeEq m0 m1) eqn:?; destruct (mTypeEq m0 m1) eqn:?;
type_conv; type_conv;
...@@ -334,6 +367,13 @@ Module ExpOrderedType (V_ordered:OrderType) <: OrderType. ...@@ -334,6 +367,13 @@ Module ExpOrderedType (V_ordered:OrderType) <: OrderType.
rewrite IHe1_1 in *; simpl in *; rewrite IHe1_1 in *; simpl in *;
rewrite CompOpp_iff in first_comp; rewrite CompOpp_iff in first_comp;
rewrite first_comp; simpl; try auto. rewrite first_comp; simpl; try auto.
-
destruct (expCompare e1_1 e2_1) eqn:first_comp;
destruct (expCompare e1_2 e2_2) eqn:second_comp;
rewrite IHe1_1, IHe1_2 in *; simpl in *;
rewrite CompOpp_iff in first_comp;
rewrite CompOpp_iff in second_comp;
rewrite first_comp, second_comp; simpl; try auto.
- rewrite mTypeEq_sym. - rewrite mTypeEq_sym.
destruct (mTypeEq m0 m) eqn:?; destruct (mTypeEq m0 m) eqn:?;
type_conv; try auto. type_conv; try auto.
...@@ -345,6 +385,12 @@ Module ExpOrderedType (V_ordered:OrderType) <: OrderType. ...@@ -345,6 +385,12 @@ Module ExpOrderedType (V_ordered:OrderType) <: OrderType.
* destruct m, m0; unfold morePrecise in *; cbv; congruence. * destruct m, m0; unfold morePrecise in *; cbv; congruence.
Qed. Qed.
Lemma expCompare_eq_sym e1 e2:
expCompare e1 e2 = Eq <-> expCompare e2 e1 = Eq.
Proof.
now split; intros H; rewrite expCompare_antisym; rewrite H.
Qed.
Lemma expCompare_lt_eq_is_lt e1: Lemma expCompare_lt_eq_is_lt e1:
forall e2 e3, forall e2 e3,
expCompare e1 e2 = Lt -> expCompare e2 e3 = Eq -> expCompare e1 e3 = Lt. expCompare e1 e2 = Lt -> expCompare e2 e3 = Eq -> expCompare e1 e3 = Lt.
...@@ -377,6 +423,16 @@ Module ExpOrderedType (V_ordered:OrderType) <: OrderType. ...@@ -377,6 +423,16 @@ Module ExpOrderedType (V_ordered:OrderType) <: OrderType.
try congruence; try congruence;
try (erewrite IHe1_1; eauto; fail ""); try (erewrite IHe1_1; eauto; fail "");
try erewrite expCompare_eq_trans; eauto. try erewrite expCompare_eq_trans; eauto.
- destruct (expCompare e1_1 e2_1) eqn:?;
destruct (expCompare e2_1 e3_1) eqn:?;
try congruence;
try (erewrite IHe1_1; eauto; fail "");
try erewrite expCompare_eq_trans; eauto.
destruct (expCompare e1_2 e2_2) eqn:?;
destruct (expCompare e2_2 e3_2) eqn:?;
try congruence;
try (erewrite IHe1_2; eauto; fail "");
try erewrite expCompare_eq_trans; eauto.
- destruct (mTypeEq m m0) eqn:?; - destruct (mTypeEq m m0) eqn:?;
destruct (mTypeEq m0 m1) eqn:?. destruct (mTypeEq m0 m1) eqn:?.
+ type_conv; subst. rewrite mTypeEq_refl. eapply IHe1; eauto. + type_conv; subst. rewrite mTypeEq_refl. eapply IHe1; eauto.
...@@ -417,6 +473,16 @@ Module ExpOrderedType (V_ordered:OrderType) <: OrderType. ...@@ -417,6 +473,16 @@ Module ExpOrderedType (V_ordered:OrderType) <: OrderType.
try congruence; try congruence;
try (erewrite IHe1_1; eauto; fail ""); try (erewrite IHe1_1; eauto; fail "");
try erewrite expCompare_eq_trans; eauto. try erewrite expCompare_eq_trans; eauto.
- destruct (expCompare e1_1 e2_1) eqn:?;
destruct (expCompare e2_1 e3_1) eqn:?;
try congruence;
try (erewrite IHe1_1; eauto; fail "");
try erewrite expCompare_eq_trans; eauto.
destruct (expCompare e1_2 e2_2) eqn:?;
destruct (expCompare e2_2 e3_2) eqn:?;
try congruence;
try (erewrite IHe1_2; eauto; fail "");
try erewrite expCompare_eq_trans; eauto.
- destruct (mTypeEq m m0) eqn:?; - destruct (mTypeEq m m0) eqn:?;
destruct (mTypeEq m0 m1) eqn:?. destruct (mTypeEq m0 m1) eqn:?.
+ type_conv; subst. rewrite mTypeEq_refl. eapply IHe1; eauto. + type_conv; subst. rewrite mTypeEq_refl. eapply IHe1; eauto.
...@@ -449,6 +515,7 @@ Module ExpOrderedType (V_ordered:OrderType) <: OrderType. ...@@ -449,6 +515,7 @@ Module ExpOrderedType (V_ordered:OrderType) <: OrderType.
apply IHx; auto. apply IHx; auto.
+ destruct b; + destruct b;
destruct (expCompare x1 x1) eqn:?; try congruence. destruct (expCompare x1 x1) eqn:?; try congruence.
+ destruct (expCompare x1 x1) eqn:?; destruct (expCompare x2 x2) eqn:?; try congruence.
+ rewrite mTypeEq_refl in lt_x. + rewrite mTypeEq_refl in lt_x.
apply IHx; auto. apply IHx; auto.
- unfold Transitive. - unfold Transitive.
...@@ -502,6 +569,19 @@ Module ExpOrderedType (V_ordered:OrderType) <: OrderType. ...@@ -502,6 +569,19 @@ Module ExpOrderedType (V_ordered:OrderType) <: OrderType.
try (erewrite expCompare_eq_lt_is_lt; eauto; fail); try (erewrite expCompare_eq_lt_is_lt; eauto; fail);
try (erewrite expCompare_lt_eq_is_lt; eauto; fail); try (erewrite expCompare_lt_eq_is_lt; eauto; fail);
try (erewrite IHe1_1; eauto). try (erewrite IHe1_1; eauto).
+ destruct (expCompare e1_1 y1) eqn:?; try congruence;
destruct (expCompare y1 z1) eqn:?; try congruence;
try (erewrite expCompare_eq_lt_is_lt; eauto; fail);
try (erewrite expCompare_lt_eq_is_lt; eauto; fail);
try (erewrite IHe1_1; eauto; fail).
apply (expCompare_eq_trans _ _ _ Heqc) in Heqc0;
rewrite Heqc0.
destruct (expCompare e1_2 y2) eqn:?; try congruence;
destruct (expCompare y2 z2) eqn:?; try congruence;
try (erewrite expCompare_eq_trans; eauto; fail);
try (erewrite expCompare_eq_lt_is_lt; eauto; fail);
try (erewrite expCompare_lt_eq_is_lt; eauto; fail);
try (erewrite IHe1_2; eauto).
+ destruct (mTypeEq m m0) eqn:?; + destruct (mTypeEq m m0) eqn:?;
destruct (mTypeEq m0 m1) eqn:?; destruct (mTypeEq m0 m1) eqn:?;
[type_conv; subst; rewrite mTypeEq_refl | | | ]. [type_conv; subst; rewrite mTypeEq_refl | | | ].
...@@ -558,6 +638,32 @@ Module ExpOrderedType (V_ordered:OrderType) <: OrderType. ...@@ -558,6 +638,32 @@ Module ExpOrderedType (V_ordered:OrderType) <: OrderType.
try (split; try congruence; intros); try (split; try congruence; intros);
try (specialize (IHe1_1 _ Heqc _ _ Heqc0); simpl in *; rewrite IHe1_1 in *; congruence); try (specialize (IHe1_1 _ Heqc _ _ Heqc0); simpl in *; rewrite IHe1_1 in *; congruence);
try (specialize (IHe1_1 _ Heqc _ _ Heqc0); simpl in *; rewrite <- IHe1_1 in *; congruence). try (specialize (IHe1_1 _ Heqc _ _ Heqc0); simpl in *; rewrite <- IHe1_1 in *; congruence).
- try (split; auto; fail);
destruct (expCompare e1_1 e2_1) eqn:?;
destruct (expCompare e3_1 e4_1) eqn:?;
try congruence;
destruct (expCompare e1_1 e3_1) eqn:?;
destruct (expCompare e2_1 e4_1) eqn:?;
try (split; congruence);
try (specialize (IHe1_2 _ e1_eq_e2 _ _ e3_eq_e4); simpl in *; rewrite IHe1_2 in *; split; auto; fail);
try (split; try congruence; intros);
try (specialize (IHe1_1 _ Heqc _ _ Heqc0); simpl in *; rewrite IHe1_1 in *; congruence);
try (specialize (IHe1_1 _ Heqc _ _ Heqc0); simpl in *; rewrite <- IHe1_1 in *; congruence);
try (split; auto; fail);
destruct (expCompare e1_2 e2_2) eqn:?;
destruct (expCompare e3_2 e4_2) eqn:?;
try congruence;
destruct (expCompare e1_2 e3_2) eqn:?;
destruct (expCompare e2_2 e4_2) eqn:?;
try (split; congruence);
try (split; try congruence; intros);
try (specialize (IHe1_2 _ Heqc3 _ _ Heqc4); simpl in *; rewrite IHe1_2 in *; congruence);
try (specialize (IHe1_2 _ Heqc3 _ _ Heqc4); simpl in *; rewrite <- IHe1_2 in *; congruence);
try congruence;
erewrite expCompare_eq_trans; eauto;
erewrite expCompare_eq_trans; eauto;
rewrite expCompare_antisym;
now (try rewrite e3_eq_e4; try rewrite e1_eq_e2).
- destruct (mTypeEq m m0) eqn:?; destruct (mTypeEq m1 m2) eqn:?; - destruct (mTypeEq m m0) eqn:?; destruct (mTypeEq m1 m2) eqn:?;
[type_conv | | |]. [type_conv | | |].
+ specialize (IHe1 _ e1_eq_e2 _ _ e3_eq_e4); simpl in *. + specialize (IHe1 _ e1_eq_e2 _ _ e3_eq_e4); simpl in *.
...@@ -606,6 +712,38 @@ Module ExpOrderedType (V_ordered:OrderType) <: OrderType. ...@@ -606,6 +712,38 @@ Module ExpOrderedType (V_ordered:OrderType) <: OrderType.
try (specialize (IHe1_1 _ Heqc _ _ Heqc0); simpl in *; rewrite <- IHe1_1 in *; congruence); try (specialize (IHe1_1 _ Heqc _ _ Heqc0); simpl in *; rewrite <- IHe1_1 in *; congruence);
try (rewrite (eq_comp _ _ Heqc _ _ Heqc0) in *; congruence); try (rewrite (eq_comp _ _ Heqc _ _ Heqc0) in *; congruence);
try (rewrite <- (eq_comp _ _ Heqc _ _ Heqc0) in *; congruence). try (rewrite <- (eq_comp _ _ Heqc _ _ Heqc0) in *; congruence).
- pose proof eq_compat as eq_comp. unfold Proper, eq in eq_comp.
destruct (expCompare e1_1 e2_1) eqn:?;
destruct (expCompare e3_1 e4_1) eqn:?;
try congruence;
destruct (expCompare e1_1 e3_1) eqn:?;
destruct (expCompare e2_1 e4_1) eqn:?;
try (split; congruence);
try (specialize (IHe1_2 _ e1_eq_e2 _ _ e3_eq_e4); simpl in *; rewrite IHe1_2 in *; split; auto; fail);
try (split; try congruence; intros);
try (specialize (IHe1_1 _ Heqc _ _ Heqc0); simpl in *; rewrite IHe1_1 in *; congruence);
try (specialize (IHe1_1 _ Heqc _ _ Heqc0); simpl in *; rewrite <- IHe1_1 in *; congruence);
try (rewrite (eq_comp _ _ Heqc _ _ Heqc0) in *; congruence);
try (rewrite <- (eq_comp _ _ Heqc _ _ Heqc0) in *; congruence);
destruct (expCompare e1_2 e2_2) eqn:?;
destruct (expCompare e3_2 e4_2) eqn:?;
try congruence;
destruct (expCompare e1_2 e3_2) eqn:?;
destruct (expCompare e2_2 e4_2) eqn:?;
try (split; congruence);
try (specialize (IHe1_3 _ e1_eq_e2 _ _ e3_eq_e4); simpl in *; rewrite IHe1_3 in *; split; auto; fail);
try (split; try congruence; intros);
try (specialize (IHe1_2 _ Heqc3 _ _ Heqc4); simpl in *; rewrite IHe1_2 in *; congruence);
try (specialize (IHe1_2 _ Heqc3 _ _ Heqc4); simpl in *; rewrite <- IHe1_2 in *; congruence);
try (rewrite (eq_comp _ _ Heqc3 _ _ Heqc4) in *; congruence);
try (rewrite <- (eq_comp _ _ Heqc3 _ _ Heqc4) in *; congruence);
try congruence.
+ apply (expCompare_lt_eq_is_lt _ _ _ H) in e3_eq_e4;
rewrite expCompare_eq_sym in e1_eq_e2;
now apply (expCompare_eq_lt_is_lt _ _ _ e1_eq_e2).
+ rewrite expCompare_eq_sym in e3_eq_e4;
apply (expCompare_lt_eq_is_lt _ _ _ H) in e3_eq_e4;
now apply (expCompare_eq_lt_is_lt _ _ _ e1_eq_e2).
- destruct (mTypeEq m m0) eqn:?; destruct (mTypeEq m1 m2) eqn:?; - destruct (mTypeEq m m0) eqn:?; destruct (mTypeEq m1 m2) eqn:?;
[type_conv | | |]. [type_conv | | |].
+ specialize (IHe1 _ e1_eq_e2 _ _ e3_eq_e4); simpl in *. + specialize (IHe1 _ e1_eq_e2 _ _ e3_eq_e4); simpl in *.
...@@ -614,7 +752,7 @@ Module ExpOrderedType (V_ordered:OrderType) <: OrderType. ...@@ -614,7 +752,7 @@ Module ExpOrderedType (V_ordered:OrderType) <: OrderType.
+ destruct (morePrecise m1 m2); congruence. + destruct (morePrecise m1 m2); congruence.
+ destruct (morePrecise m m0); congruence. + destruct (morePrecise m m0); congruence.
+ destruct (morePrecise m m0); congruence. + destruct (morePrecise m m0); congruence.
Defined. Qed.
Lemma compare_spec : forall x y, CompSpec eq lt x y (expCompare x y). Lemma compare_spec : forall x y, CompSpec eq lt x y (expCompare x y).
Proof. Proof.
...@@ -685,11 +823,12 @@ End ExpOrderedType. ...@@ -685,11 +823,12 @@ End ExpOrderedType.
Fixpoint toRExp (e:exp Q) := Fixpoint toRExp (e:exp Q) :=
match e with match e with
|Var _ v => Var R v | Var _ v => Var R v
|Const m n => Const m (Q2R n) | Const m n => Const m (Q2R n)
|Unop o e1 => Unop o (toRExp e1) | Unop o e1 => Unop o (toRExp e1)
|Binop o e1 e2 => Binop o (toRExp e1) (toRExp e2) | Binop o e1 e2 => Binop o (toRExp e1) (toRExp e2)
|Downcast m e1 => Downcast m (toRExp e1) | Fma e1 e2 e3 => Fma (toRExp e1) (toRExp e2) (toRExp e3)
| Downcast m e1 => Downcast m (toRExp e1)
end. end.
Fixpoint toREval (e:exp R) := Fixpoint toREval (e:exp R) :=
...@@ -698,6 +837,7 @@ Fixpoint toREval (e:exp R) := ...@@ -698,6 +837,7 @@ Fixpoint toREval (e:exp R) :=
| Const _ n => Const M0 n | Const _ n => Const M0 n
| Unop o e1 => Unop o (toREval e1) | Unop o e1 => Unop o (toREval e1)
| Binop o e1 e2 => Binop o (toREval e1) (toREval e2) | Binop o e1 e2 => Binop o (toREval e1) (toREval e2)
| Fma e1 e2 e3 => Fma (toREval e1) (toREval e2) (toREval e3)
| Downcast _ e1 => Downcast M0 (toREval e1) | Downcast _ e1 => Downcast M0 (toREval e1)
end. end.
...@@ -750,7 +890,15 @@ Inductive eval_exp (E:env) (Gamma: nat -> option mType) :(exp R) -> R -> mType - ...@@ -750,7 +890,15 @@ Inductive eval_exp (E:env) (Gamma: nat -> option mType) :(exp R) -> R -> mType -
eval_exp E Gamma f1 v1 m1 -> eval_exp E Gamma f1 v1 m1 ->
eval_exp E Gamma f2 v2 m2 -> eval_exp E Gamma f2 v2 m2 ->
((op = Div) -> (~ v2 = 0)%R) -> ((op = Div) -> (~ v2 = 0)%R) ->
eval_exp E Gamma (Binop op f1 f2) (perturb (evalBinop op v1 v2) delta) (join m1 m2). eval_exp E Gamma (Binop op f1 f2) (perturb (evalBinop op v1 v2) delta) (join m1 m2)
| Fma_dist m1 m2 m3 f1 f2 f3 v1 v2 v3 delta:
Rle (Rabs delta) (Q2R (mTypeToQ (join3 m1 m2 m3))) ->
eval_exp E Gamma f1 v1 m1 ->
eval_exp E Gamma f2 v2 m2 ->
eval_exp E Gamma f3 v3 m3 ->
eval_exp E Gamma (Fma f1 f2 f3)
(perturb (evalFma v1 v2 v3) delta)
(join3 m1 m2 m3).
Hint Constructors eval_exp. Hint Constructors eval_exp.
...@@ -819,6 +967,20 @@ Qed. ...@@ -819,6 +967,20 @@ Qed.
Hint Resolve Binop_dist'. Hint Resolve Binop_dist'.
Lemma Fma_dist' m1 m2 m3 f1 f2 f3 v1 v2 v3 delta v m' E Gamma:
Rle (Rabs delta) (Q2R (mTypeToQ m')) ->
eval_exp E Gamma f1 v1 m1 ->
eval_exp E Gamma f2 v2 m2 ->
eval_exp E Gamma f3 v3 m3 ->
v = perturb (evalFma v1 v2 v3) delta ->
m' = join3 m1 m2 m3 ->
eval_exp E Gamma (Fma f1 f2 f3) v m'.
Proof.
intros; subst; auto.
Qed.
Hint Resolve Fma_dist'.
(** (**
Define the set of "used" variables of an expression to be the set of variables Define the set of "used" variables of an expression to be the set of variables
occuring in it occuring in it
...@@ -828,6 +990,7 @@ Fixpoint usedVars (V:Type) (e:exp V) :NatSet.t := ...@@ -828,6 +990,7 @@ Fixpoint usedVars (V:Type) (e:exp V) :NatSet.t :=
| Var _ x => NatSet.singleton x | Var _ x => NatSet.singleton x
| Unop u e1 => usedVars e1 | Unop u e1 => usedVars e1
| Binop b e1 e2 => NatSet.union (usedVars e1) (usedVars e2) | Binop b e1 e2 => NatSet.union (usedVars e1) (usedVars e2)
| Fma e1 e2 e3 => NatSet.union (usedVars e1) (NatSet.union (usedVars e2) (usedVars e3))
| Downcast _ e1 => usedVars e1 | Downcast _ e1 => usedVars e1
| _ => NatSet.empty | _ => NatSet.empty
end. end.
...@@ -851,6 +1014,13 @@ Proof. ...@@ -851,6 +1014,13 @@ Proof.
assert (m2 = M0) assert (m2 = M0)
by (eapply IHf2; eauto); by (eapply IHf2; eauto);
subst; auto. subst; auto.
- assert (m1 = M0)
by (eapply IHf1; eauto).
assert (m2 = M0)
by (eapply IHf2; eauto).
assert (m3 = M0)
by (eapply IHf3; eauto);
subst; auto.
Qed. Qed.
(** (**
...@@ -899,6 +1069,20 @@ Proof. ...@@ -899,6 +1069,20 @@ Proof.
simpl in *. simpl in *.
rewrite Q2R0_is_0 in *. rewrite Q2R0_is_0 in *.
repeat (rewrite delta_0_deterministic; try auto). repeat (rewrite delta_0_deterministic; try auto).
- inversion ev1; inversion ev2; subst.
assert (m0 = M0) by (eapply toRMap_eval_M0; eauto).
assert (m1 = M0) by (eapply toRMap_eval_M0; eauto).
assert (m2 = M0) by (eapply toRMap_eval_M0; eauto).
assert (m3 = M0) by (eapply toRMap_eval_M0; eauto).
assert (m4 = M0) by (eapply toRMap_eval_M0; eauto).
assert (m5 = M0) by (eapply toRMap_eval_M0; eauto).
subst.
rewrite (IHf1 v0 v5); try auto.
rewrite (IHf2 v3 v6); try auto.
rewrite (IHf3 v4 v7); try auto.
simpl in *.
rewrite Q2R0_is_0 in *.
repeat (rewrite delta_0_deterministic; try auto).
- inversion ev1; inversion ev2; subst. - inversion ev1; inversion ev2; subst.
apply M0_least_precision in H1; apply M0_least_precision in H1;
apply M0_least_precision in H7; subst.