Skip to content

GitLab

F
FloVer
Commit 313ac660 authored by Heiko Becker's avatar Heiko Becker
Browse files
Options

Fix Fixed-Point implementation by properly implementing type join for fixed-points

parent c6efd235
Expand all Hide whitespace changes
Inline Side-by-side
Showing with 1773 additions and 941 deletions
coq/AffineValidation.v
View file @ 313ac660
This diff is collapsed.
coq/CertificateChecker.v
View file @ 313ac660
......@@ -12,9 +12,10 @@ From Flover
Require Export Infra.ExpressionAbbrevs Flover.Commands Coq.QArith.QArith.
(** Certificate checking function **)
Definition CertificateChecker (e:expr Q) (absenv:analysisResult) (P:precond) (defVars:nat -> option mType) :=
let tMap := (typeMap defVars e (FloverMap.empty mType)) in
if (typeCheck e defVars tMap)
Definition CertificateChecker (e:expr Q) (absenv:analysisResult)
(P:precond) (defVars:nat -> option mType) (fBits:FloverMap.t nat):=
let tMap := (typeMap defVars e (FloverMap.empty mType) fBits) in
if (typeCheck e defVars tMap fBits)
then
if RangeValidator e absenv P NatSet.empty && FPRangeValidator e absenv tMap NatSet.empty
then RoundoffErrorValidator e tMap absenv NatSet.empty
......@@ -26,7 +27,8 @@ Definition CertificateChecker (e:expr Q) (absenv:analysisResult) (P:precond) (de
Apart from assuming two executions, one in R and one on floats, we assume that
the real valued execution respects the precondition.
**)
Theorem Certificate_checking_is_sound (e:expr Q) (absenv:analysisResult) P defVars:
Theorem Certificate_checking_is_sound (e:expr Q) (absenv:analysisResult) P
defVars fBits:
forall (E1 E2:env),
approxEnv E1 defVars absenv (usedVars e) NatSet.empty E2 ->
(forall v, NatSet.In v (Expressions.usedVars e) ->
......@@ -35,13 +37,13 @@ Theorem Certificate_checking_is_sound (e:expr Q) (absenv:analysisResult) P defVa
(forall v, NatSet.In v (usedVars e) ->
exists m : mType,
defVars v = Some m) ->
CertificateChecker e absenv P defVars = true ->
CertificateChecker e absenv P defVars fBits = true ->
exists iv err vR vF m,
FloverMap.find e absenv = Some (iv, err) /\
eval_expr E1 (toRMap defVars) (toREval (toRExp e)) vR REAL /\
eval_expr E2 defVars (toRExp e) vF m /\
eval_expr E1 (toRMap defVars) (toRBMap fBits) (toREval (toRExp e)) vR REAL /\
eval_expr E2 defVars (toRBMap fBits) (toRExp e) vF m /\
(forall vF m,
eval_expr E2 defVars (toRExp e) vF m ->
eval_expr E2 defVars (toRBMap fBits) (toRExp e) vF m ->
(Rabs (vR - vF) <= Q2R err))%R.
(**
The proofs is a simple composition of the soundness proofs for the range
......@@ -68,19 +70,20 @@ Proof.
{ unfold vars_typed. intros; apply types_defined. set_tac. destruct H1; set_tac.
split; try auto. hnf; intros; set_tac. }
rename R into validFPRanges.
assert (validRanges e absenv E1 defVars) as valid_e.
assert (validRanges e absenv E1 defVars (toRBMap fBits)) as valid_e.
{ eapply (RangeValidator_sound e (dVars:=NatSet.empty) (A:=absenv) (P:=P) (Gamma:=defVars) (E:=E1));
auto. }
pose proof (validRanges_single _ _ _ _ valid_e) as valid_single;
pose proof (validRanges_single _ _ _ _ _ valid_e) as valid_single;
destruct valid_single as [iv_e [ err_e [vR [ map_e [eval_real real_bounds_e]]]]].
destruct iv_e as [elo ehi].
edestruct (RoundoffErrorValidator_sound e (typeMap defVars e (FloverMap.empty mType)) L approxE1E2 H0 eval_real R0 valid_e H1 map_e) as [[vF [mF eval_float]] err_bounded]; auto.
edestruct (RoundoffErrorValidator_sound e (typeMap defVars e (FloverMap.empty mType) fBits) L approxE1E2 H0 eval_real R0 valid_e H1 map_e) as [[vF [mF eval_float]] err_bounded]; auto.
exists (elo, ehi), err_e, vR, vF, mF; split; auto.
Qed.
Definition CertificateCheckerCmd (f:cmd Q) (absenv:analysisResult) (P:precond) defVars:=
let tMap := typeMapCmd defVars f (FloverMap.empty mType) in
if (typeCheckCmd f defVars tMap && validSSA f (freeVars f))
Definition CertificateCheckerCmd (f:cmd Q) (absenv:analysisResult) (P:precond)
defVars fBits:=
let tMap := typeMapCmd defVars f (FloverMap.empty mType) fBits in
if (typeCheckCmd f defVars tMap fBits && validSSA f (freeVars f))
then
if (RangeValidatorCmd f absenv P NatSet.empty) &&
FPRangeValidatorCmd f absenv tMap NatSet.empty
......@@ -88,7 +91,8 @@ Definition CertificateCheckerCmd (f:cmd Q) (absenv:analysisResult) (P:precond) d
else false
else false.
Theorem Certificate_checking_cmds_is_sound (f:cmd Q) (absenv:analysisResult) P defVars:
Theorem Certificate_checking_cmds_is_sound (f:cmd Q) (absenv:analysisResult) P
defVars fBits:
forall (E1 E2:env),
approxEnv E1 defVars absenv (freeVars f) NatSet.empty E2 ->
(forall v, NatSet.In v (freeVars f) ->
......@@ -97,13 +101,13 @@ Theorem Certificate_checking_cmds_is_sound (f:cmd Q) (absenv:analysisResult) P d
(forall v, NatSet.In v (freeVars f) ->
exists m : mType,
defVars v = Some m) ->
CertificateCheckerCmd f absenv P defVars = true ->
CertificateCheckerCmd f absenv P defVars fBits = true ->
exists iv err vR vF m,
FloverMap.find (getRetExp f) absenv = Some (iv,err) /\
bstep (toREvalCmd (toRCmd f)) E1 (toRMap defVars) vR REAL /\
bstep (toRCmd f) E2 defVars vF m /\
bstep (toREvalCmd (toRCmd f)) E1 (toRMap defVars) (toRBMap fBits) vR REAL /\
bstep (toRCmd f) E2 defVars (toRBMap fBits) vF m /\
(forall vF m,
bstep (toRCmd f) E2 defVars vF m ->
bstep (toRCmd f) E2 defVars (toRBMap fBits) vF m ->
(Rabs (vR - vF) <= Q2R (err))%R).
(**
The proofs is a simple composition of the soundness proofs for the range
......@@ -129,11 +133,11 @@ Proof.
destruct H0; set_tac. }
assert (NatSet.Subset (freeVars f -- NatSet.empty) (freeVars f))
as freeVars_contained by set_tac.
assert (validRangesCmd f absenv E1 defVars) as valid_f.
assert (validRangesCmd f absenv E1 defVars (toRBMap fBits)) as valid_f.
{ eapply RangeValidatorCmd_sound; eauto.
unfold affine_dVars_range_valid; intros.
set_tac. }
pose proof (validRangesCmd_single _ _ _ _ valid_f) as valid_single.
pose proof (validRangesCmd_single _ _ _ _ _ valid_f) as valid_single.
destruct valid_single as [iv [ err [vR [map_f [eval_real bounded_real_f]]]]].
destruct iv as [f_lo f_hi].
edestruct (RoundoffErrorValidatorCmd_sound) as [[vF [mF eval_float]] ?]; eauto.
......
coq/Commands.v
View file @ 313ac660
......@@ -49,14 +49,14 @@ Inductive sstep : cmd R -> env -> R -> cmd R -> env -> Prop :=
Define big step semantics for the Flover language, terminating on a "returned"
result value
**)
Inductive bstep : cmd R -> env -> (nat -> option mType) -> R -> mType -> Prop :=
let_b m m' x e s E v res defVars:
eval_expr E defVars e v m ->
bstep s (updEnv x v E) (updDefVars x m defVars) res m' ->
bstep (Let m x e s) E defVars res m'
|ret_b m e E v defVars:
eval_expr E defVars e v m ->
bstep (Ret e) E defVars v m.
Inductive bstep : cmd R -> env -> (nat -> option mType) -> (expr R -> option nat) -> R -> mType -> Prop :=
let_b m m' x e s E v res defVars fBits:
eval_expr E defVars fBits e v m ->
bstep s (updEnv x v E) (updDefVars x m defVars) fBits res m' ->
bstep (Let m x e s) E defVars fBits res m'
|ret_b m e E v defVars fBits:
eval_expr E defVars fBits e v m ->
bstep (Ret e) E defVars fBits v m.
(**
The free variables of a command are all used variables of exprressions
......@@ -88,14 +88,14 @@ Fixpoint liveVars V (f:cmd V) :NatSet.t :=
end.
Lemma bstep_eq_env f:
forall E1 E2 Gamma v m,
forall E1 E2 Gamma fBits v m,
(forall x, E1 x = E2 x) ->
bstep f E1 Gamma v m ->
bstep f E2 Gamma v m.
bstep f E1 Gamma fBits v m ->
bstep f E2 Gamma fBits v m.
Proof.
induction f; intros * eq_envs bstep_E1;
inversion bstep_E1; subst; simpl in *.
- eapply eval_eq_env in H7; eauto. eapply let_b; eauto.
- eapply eval_eq_env in H8; eauto. eapply let_b; eauto.
eapply IHf. instantiate (1:=(updEnv n v0 E1)).
+ intros; unfold updEnv.
destruct (x=? n); auto.
......
coq/ErrorBounds.v
View file @ 313ac660
This diff is collapsed.
coq/ErrorValidation.v
View file @ 313ac660
This diff is collapsed.
coq/ErrorValidationAA.v
View file @ 313ac660
......@@ -219,17 +219,17 @@ Fixpoint validErrorboundAACmd (f:cmd Q) (* analyzed cmd with let's *)
|Ret e => validErrorboundAA e typeMap A dVars currNoise errMap
end.
Definition checked_error_expressions (A: analysisResult) (E1 E2:env) Gamma e
(initMap:FloverMap.t (affine_form Q)) currNoise (M1:noise_mapping) vR :=
eval_expr E1 (toRMap Gamma) (toREval (toRExp e)) vR REAL ->
exists (af:affine_form Q) (vF:R) m aiv aerr,
eval_expr E2 Gamma (toRExp e) vF m /\
FloverMap.find (elt:=intv * error) e A = Some (aiv, aerr) /\
FloverMap.find (elt:= affine_form Q) e initMap = Some af /\
fresh currNoise af /\
(forall n, (n >= currNoise)%nat -> M1 n = None) /\
let mAbs := maxAbs (toIntv af) in
(Rabs (vR - vF) <= (Q2R mAbs))%R.
(* Definition checked_error_expressions (A: analysisResult) (E1 E2:env) Gamma e *)
(* (initMap:FloverMap.t (affine_form Q)) currNoise (M1:noise_mapping) vR := *)
(* eval_expr E1 (toRMap Gamma) (toREval (toRExp e)) vR REAL -> *)
(* exists (af:affine_form Q) (vF:R) m aiv aerr, *)
(* eval_expr E2 Gamma (toRExp e) vF m /\ *)
(* FloverMap.find (elt:=intv * error) e A = Some (aiv, aerr) /\ *)
(* FloverMap.find (elt:= affine_form Q) e initMap = Some af /\ *)
(* fresh currNoise af /\ *)
(* (forall n, (n >= currNoise)%nat -> M1 n = None) /\ *)
(* let mAbs := maxAbs (toIntv af) in *)
(* (Rabs (vR - vF) <= (Q2R mAbs))%R. *)
(* Theorem validErrorboundAA_sound e: *)
(* forall E1 E2 P Gamma defVars nR A elo ehi tMap fVars dVars currNoise maxNoise initMap resMap M1, *)
......
coq/Expressions.v
View file @ 313ac660
......@@ -457,11 +457,11 @@ Proof.
Qed.
Lemma eval_expr_ignore_bind e:
forall x v m Gamma E,
eval_expr E Gamma e v m ->
forall x v m Gamma E fBits,
eval_expr E Gamma fBits e v m ->
~ NatSet.In x (usedVars e) ->
forall m_new v_new,
eval_expr (updEnv x v_new E) (updDefVars x m_new Gamma) e v m.
eval_expr (updEnv x v_new E) (updDefVars x m_new Gamma) fBits e v m.
Proof.
induction e; intros * eval_e no_usedVar *; cbn in *;
inversion eval_e; subst; try eauto.
......
coq/FPRangeValidator.v
View file @ 313ac660
......@@ -57,7 +57,7 @@ Ltac prove_fprangeval m v L1 R:=
unfold normal, Normal, validValue, Denormal in *; canonize_hyps;
try rewrite orb_true_iff in *;
destruct L1; destruct R; canonize_hyps;
rewrite <- Rabs_eq_Qabs in *;
try rewrite <- Rabs_eq_Qabs in *;
Q2R_to_head;
rewrite <- Q2R_minus, <- Q2R_plus in *;
repeat (match goal with
......@@ -69,17 +69,19 @@ Ltac prove_fprangeval m v L1 R:=
destruct (Rle_lt_dec (Rabs v) (Q2R (maxValue m)))%R; lra.
Theorem FPRangeValidator_sound:
forall (e:expr Q) E1 E2 Gamma v m A tMap fVars dVars,
forall (e:expr Q) E1 E2 Gamma v m A tMap fVars dVars fBits,
approxEnv E1 Gamma A fVars dVars E2 ->
eval_expr E2 Gamma (toRExp e) v m ->
typeCheck e Gamma tMap = true ->
validRanges e A E1 Gamma ->
eval_expr E2 Gamma (toRBMap fBits) (toRExp e) v m ->
typeCheck e Gamma tMap fBits = true ->
validRanges e A E1 Gamma (toRBMap fBits) ->
validErrorbound e tMap A dVars = true ->
FPRangeValidator e A tMap dVars = true ->
NatSet.Subset (NatSet.diff (usedVars e) dVars) fVars ->
vars_typed (NatSet.union fVars dVars) Gamma ->
(forall v, NatSet.In v dVars ->
exists vF m, E2 v = Some vF /\ FloverMap.find (Var Q v) tMap = Some m /\ validFloatValue vF m) ->
exists vF m, E2 v = Some vF /\
FloverMap.find (Var Q v) tMap = Some m /\
validFloatValue vF m) ->
validFloatValue v m.
Proof.
intros *.
......@@ -89,7 +91,7 @@ Proof.
as type_e
by (eapply typingSoundnessExp; eauto).
unfold validFloatValue.
pose proof (validRanges_single _ _ _ _ H2) as valid_e.
pose proof (validRanges_single _ _ _ _ _ H2) as valid_e.
destruct valid_e as [iv_e [err_e [vR[ map_e[eval_real vR_bounded]]]]].
destruct iv_e as [e_lo e_hi].
assert (Rabs (vR - v) <= Q2R (err_e))%R.
......@@ -119,37 +121,83 @@ Proof.
- Flover_compute; destruct u; Flover_compute; try congruence.
type_conv; subst.
prove_fprangeval m0 v L1 R.
- Flover_compute; try congruence.
type_conv; subst.
prove_fprangeval (join m0 m1) v L1 R.
- Flover_compute; try congruence.
type_conv; subst.
prove_fprangeval (join3 m0 m1 m2) v L1 R.
- inversion H0; subst.
assert (FloverMap.find e1 tMap = Some m1) as type_m1.
{ eapply typingSoundnessExp; eauto.
Flover_compute; auto. }
assert (FloverMap.find e2 tMap = Some m2) as type_m2.
{ eapply typingSoundnessExp; eauto.
Flover_compute; auto. }
rewrite type_m1, type_m2 in *.
destruct (isFixedPointB m1) eqn:?;
destruct (isFixedPointB m2) eqn:?;
[ | destruct m1, m2; cbn in *; congruence
| destruct m1, m2; cbn in *; congruence | ];
simpl in H1.
+ Flover_compute; try congruence.
type_conv; subst.
prove_fprangeval m0 (perturb (evalBinop b v1 v2) m0 delta) L1 R.
+ Flover_compute; try congruence.
type_conv; subst.
prove_fprangeval m0 (perturb (evalBinop b v1 v2) m0 delta) L1 R.
- inversion H0; subst.
assert (FloverMap.find e1 tMap = Some m1) as type_m1.
{ eapply typingSoundnessExp; eauto.
clear H4 H3.
Flover_compute; auto. }
assert (FloverMap.find e2 tMap = Some m2) as type_m2.
{ eapply typingSoundnessExp; eauto.
clear H4 H3.
Flover_compute; auto. }
assert (FloverMap.find e3 tMap = Some m3) as type_m3.
{ eapply typingSoundnessExp; eauto.
clear H4 H3.
Flover_compute; auto. }
rewrite type_m1, type_m2, type_m3 in *.
edestruct typingFma_fixedPoint_case with (e1:=e1) (e2:=e2) (e3:=e3)
as [all_fixed | [m1_float [m2_float m3_float]]];
eauto.
+ cbn. clear H3 H4.
rewrite type_m1, type_m2, type_m3, type_e.
eauto.
+ andb_to_prop all_fixed.
rewrite L0, R0, R in *.
simpl in H1.
Flover_compute; try congruence.
type_conv; subst.
prove_fprangeval m0 (perturb (evalFma v1 v2 v3) m0 delta) L1 R.
+ rewrite m1_float, m2_float, m3_float in *;
simpl in H1.
Flover_compute; try congruence.
type_conv; subst.
prove_fprangeval m0 (perturb (evalFma v1 v2 v3) m0 delta) L1 R.
- Flover_compute; try congruence.
type_conv; subst.
prove_fprangeval m v L1 R.
Qed.
Lemma FPRangeValidatorCmd_sound (f:cmd Q):
forall E1 E2 Gamma v vR m A tMap fVars dVars outVars,
forall E1 E2 Gamma v vR m A tMap fVars dVars outVars fBits,
approxEnv E1 Gamma A fVars dVars E2 ->
ssa f (NatSet.union fVars dVars) outVars ->
bstep (toREvalCmd (toRCmd f)) E1 (toRMap Gamma) vR m ->
bstep (toRCmd f) E2 Gamma v m ->
typeCheckCmd f Gamma tMap = true ->
validRangesCmd f A E1 Gamma ->
bstep (toREvalCmd (toRCmd f)) E1 (toRMap Gamma) (toRBMap fBits) vR m ->
bstep (toRCmd f) E2 Gamma (toRBMap fBits) v m ->
typeCheckCmd f Gamma tMap fBits = true ->
validRangesCmd f A E1 Gamma (toRBMap fBits) ->
validErrorboundCmd f tMap A dVars = true ->
FPRangeValidatorCmd f A tMap dVars = true ->
NatSet.Subset (NatSet.diff (freeVars f) dVars) fVars ->
vars_typed (NatSet.union fVars dVars) Gamma ->
(forall v, NatSet.In v dVars ->
exists vF m, E2 v = Some vF /\ FloverMap.find (Var Q v) tMap = Some m /\ validFloatValue vF m) ->
exists vF m, E2 v = Some vF /\
FloverMap.find (Var Q v) tMap = Some m /\
validFloatValue vF m) ->
validFloatValue v m.
Proof.
induction f; intros;
simpl in *;
(match_pat (bstep _ _ (toRMap _) _ _) (fun H => inversion H; subst; simpl in *));
(match_pat (bstep _ _ Gamma _ _) (fun H => inversion H; subst; simpl in *));
(match_pat (bstep _ _ (toRMap _) _ _ _) (fun H => inversion H; subst; simpl in *));
(match_pat (bstep _ _ Gamma _ _ _) (fun H => inversion H; subst; simpl in *));
repeat match goal with
| H : _ = true |- _ => andb_to_prop H
end.
......@@ -158,7 +206,7 @@ Proof.
match_pat (ssa _ _ _) (fun H => inversion H; subst; simpl in *).
Flover_compute.
destruct H4 as [[valid_e valid_rec] valid_single].
pose proof (validRanges_single _ _ _ _ valid_e) as valid_e_single.
pose proof (validRanges_single _ _ _ _ _ valid_e) as valid_e_single.
destruct valid_e_single
as [iv_e [err_e [vR_e [map_e [eval_e_real bounded_vR_e]]]]].
destr_factorize.
......@@ -170,10 +218,10 @@ Proof.
split; try auto.
hnf; intros; subst; set_tac.
+ destruct iv_e; auto.
+ rewrite <- (meps_0_deterministic (toRExp e) eval_e_real H18) in *; try auto.
+ rewrite <- (meps_0_deterministic (toRExp e) eval_e_real H19) in *; try auto.
apply (IHf (updEnv n vR_e E1) (updEnv n v1 E2)
(updDefVars n m Gamma) v vR m0 A tMap fVars
(NatSet.add n dVars) (outVars)); eauto.
(NatSet.add n dVars) (outVars) fBits); eauto.
* eapply approxUpdBound; eauto.
simpl in *.
apply Rle_trans with (r2:= Q2R err_e); try lra.
......
coq/IEEE_connection.v
View file @ 313ac660
This diff is collapsed.
coq/Infra/ExpressionAbbrevs.v
View file @ 313ac660
......@@ -2,14 +2,14 @@
Some abbreviations that require having defined exprressions beforehand
If we would put them in the Abbrevs file, this would create a circular dependency which Coq cannot resolve.
**)
Require Import Coq.QArith.QArith Coq.Reals.Reals Coq.QArith.Qreals Coq.QArith.QOrderedType Coq.FSets.FMapAVL Coq.FSets.FMapFacts Recdef.
Require Import Flover.AffineForm.
Require Export Flover.Infra.Abbrevs Flover.Expressions Flover.OrderedExpressions.
Require Import Coq.QArith.QArith Coq.Reals.Reals Coq.QArith.Qreals Coq.QArith.QOrderedType Coq.FSets.FMapAVL Coq.FSets.FMapFacts Coq.Reals.ROrderedType Recdef.
Require Export Flover.Infra.Abbrevs Flover.AffineForm Flover.Expressions Flover.Infra.Ltacs Flover.OrderedExpressions.
Module Q_orderedExps := ExprOrderedType (Q_as_OT).
Module legacy_OrderedQExps := Structures.OrdersAlt.Backport_OT (Q_orderedExps).
Module R_orderedExps := ExprOrderedType (R_as_OT).
Functional Scheme exprCompare_ind := Induction for Q_orderedExps.exprCompare Sort Prop.
Lemma expr_compare_eq_eval_compat (e1 e2: expr Q):
......@@ -21,30 +21,74 @@ Proof.
try now apply Nat.compare_eq.
- rewrite <- Qeq_alt in Heq.
now apply Qeq_eqR.
- apply Ndec.Pcompare_Peqb in e6.
apply Pos.eqb_eq in e6; subst.
apply Nat.compare_eq in Heq; subst; auto.
- simpl in e3.
apply andb_false_iff in e3.
apply Ndec.Pcompare_Peqb in e6.
apply Ndec.Pcompare_Peqb in Heq.
destruct e3; congruence.
- simpl in e3.
apply andb_false_iff in e3.
apply Ndec.Pcompare_Peqb in e6.
apply Ndec.Pcompare_Peqb in Heq.
apply Pos.eqb_eq in e6; subst.
apply Nat.compare_eq in Heq; subst; auto.
rewrite Nat.eqb_refl, Pos.eqb_refl in e3.
destruct e3; congruence.
- unfold unopEq in e5.
destruct u1, u2; congruence.
- simpl in e5.
apply andb_false_iff in e5.
apply Ndec.Pcompare_Peqb in e8.
apply Ndec.Pcompare_Peqb in Heq.
rewrite Pos.eqb_eq in e8; subst.
apply Nat.compare_eq in Heq; subst.
destruct e5; congruence.
- simpl in e5.
apply andb_false_iff in e5.
apply Ndec.Pcompare_Peqb in e8.
apply Ndec.Pcompare_Peqb in Heq.
rewrite Pos.eqb_eq in e8.
apply Nat.compare_eq in Heq; subst.
rewrite Nat.eqb_refl, Pos.eqb_refl in *.
destruct e5; congruence.
Qed.
Lemma Qcompare_Rcompare q1 q2 c:
Qcompare q1 q2 = c ->
Rcompare (Q2R q1) (Q2R q2) = c.
Proof.
intros q_check; destruct c.
- rewrite <- Qeq_alt in q_check.
apply Qeq_eqR in q_check.
rewrite q_check in *.
rewrite R_orderedExps.V_orderedFacts.compare_refl in *; auto.
- rewrite <- Qlt_alt in q_check.
apply Qlt_Rlt in q_check.
rewrite R_orderedExps.V_orderedFacts.compare_lt_iff; auto.
- rewrite <- Qgt_alt in q_check.
rewrite R_orderedExps.V_orderedFacts.compare_gt_iff.
auto using Qlt_Rlt.
Qed.
Lemma QcompareExp_RcompareExp e1 e2:
Q_orderedExps.exprCompare e1 e2 = R_orderedExps.exprCompare (toRExp e1) (toRExp e2).
Proof.
functional induction (Q_orderedExps.exprCompare e1 e2); simpl in *; try auto; try congruence;
try rewrite e3;
try rewrite <- IHc, e6; try auto.
- destruct (Qcompare v1 v2) eqn:q_comp; apply Qcompare_Rcompare in q_comp; auto.
- rewrite e6; auto.
- rewrite e6; auto.
- rewrite e6; auto.
- rewrite e5, IHc; auto.
- rewrite e5, e6; auto.
- rewrite e5, e6; auto.
- rewrite <- IHc, <- IHc0, e4, e3; auto.
- rewrite <- IHc, e3, <- IHc0, e4; auto.
- rewrite <- IHc, e3, <- IHc0, e4; auto.
- rewrite <- IHc, e3; auto.
- rewrite <- IHc, e3; auto.
- rewrite <- IHc, e5; auto.
- rewrite e5, e8; auto.
- rewrite e5, e8; auto.
- rewrite e5, e8; auto.
Qed.
Module FloverMap := FMapAVL.Make(legacy_OrderedQExps).
Module FloverMapFacts := OrdProperties (FloverMap).
......@@ -88,6 +132,67 @@ Proof.
auto.
Qed.
Definition toRBMap (bMap:FloverMap.t nat) : expr R -> option nat :=
let elements := FloverMap.elements (elt:=nat) bMap in
fun (e:expr R) =>
olet p := find (fun p => match R_orderedExps.compare e (toRExp (fst p)) with
| Eq => true |_ => false end) elements in
Some (snd p).
Lemma findA_find A B (f:A -> bool) (l:list (A * B)) r:
findA f l = Some r ->
exists k,
find (fun p => f (fst p)) l = Some (k,r) /\ f k = true.
Proof.
induction l.
- intros; simpl in *; congruence.
- intros findA_top.
simpl in *.
destruct a; simpl in *.
destruct (f a) eqn:?; try auto.
exists a; split; congruence.
Qed.
Lemma find_swap A (f1:A -> bool) f2 l r:
(forall k, f1 k = f2 k) ->
find f1 l = Some r ->
find f2 l = Some r.
Proof.
induction l; intros f_eq find1; simpl in *; try congruence.
destruct (f1 a) eqn:?.
- rewrite <- f_eq; rewrite Heqb; congruence.
- rewrite <- f_eq; rewrite Heqb.
apply IHl; auto.
Qed.
Lemma toRBMap_some bMap e b:
FloverMap.find e bMap = Some b ->
toRBMap bMap (toRExp e) = Some b.
Proof.
intros find_Q.
rewrite FloverMapFacts.P.F.elements_o in find_Q.
unfold toRBMap.
unfold optionBind.
apply findA_find in find_Q as [key [find_Q k_eq]].
unfold FloverMapFacts.P.F.eqb in k_eq.
cut (find
(fun p : expr Q * nat =>
match R_orderedExps.compare (toRExp e) (toRExp (fst p)) with
| Eq => true
| _ => false
end) (FloverMap.elements (elt:=nat) bMap) = Some (key, b)).
- intros find_R. rewrite find_R. auto.
- eapply find_swap with (f1 := fun p => match Q_orderedExps.exprCompare e (fst p) with
|Eq => true |_ => false end).
+ intros. rewrite <- QcompareExp_RcompareExp; auto.
+ eapply find_swap; eauto.
intros; simpl.
destruct (Q_orderedExps.exprCompare e (fst k)) eqn:q_comp.
all: unfold FloverMapFacts.P.F.eqb.
all: unfold FloverMapFacts.P.F.eq_dec.
all: rewrite q_comp; auto.
Qed.
(**
We treat a function mapping an exprression arguing on fractions as value type
to pairs of intervals on rationals and rational errors as the analysis result
......
coq/Infra/MachineType.v
View file @ 313ac660
......@@ -351,6 +351,30 @@ Definition join3 (m1:mType) (m2:mType) (m3:mType) (fBits:nat):=
olet msub := (join m2 m3 fBits) in
join m1 msub fBits.
Lemma join_float m1 m2 f1 f2:
~ isFixedPoint m1 ->
~ isFixedPoint m2 ->
join m1 m2 f1 = join m1 m2 f2.
Proof.
intros. destruct m1, m2; simpl in *; try congruence.
exfalso. auto.
Qed.
Corollary join3_float m1 m2 m3 f1 f2:
~ isFixedPoint m1 ->
~ isFixedPoint m2 ->
~ isFixedPoint m3 ->
join3 m1 m2 m3 f1 = join3 m1 m2 m3 f2.
Proof.
intros.
unfold join3.
erewrite join_float with (f2:=f2); eauto.
destruct (join m2 m3 f2) eqn:?; try auto.
simpl. apply join_float; auto.
destruct m2, m3; simpl in *; inversion Heqo; subst; hnf; simpl; try congruence.
exfalso. auto.
Qed.
(* Lemma REAL_join_is_REAL m1 m2: *)
(* join m1 m2 = REAL -> m1 = REAL /\ m2 = REAL. *)
(* Proof. *)
......
coq/IntervalValidation.v
View file @ 313ac660
......@@ -132,17 +132,13 @@ Proof.
Qed.
Theorem validIntervalbounds_sound (f:expr Q) (A:analysisResult) (P:precond)
fVars dVars (E:env) Gamma:
fVars dVars (E:env) Gamma fBits:
validIntervalbounds f A P dVars = true ->
dVars_range_valid dVars E A ->
NatSet.Subset (NatSet.diff (Expressions.usedVars f) dVars) fVars ->
fVars_P_sound fVars E P ->
vars_typed (NatSet.union fVars dVars) Gamma ->
validRanges f A E Gamma.
(* exists iv err vR, *)
(* FloverMap.find f A = Some (iv, err) /\ *)
(* eval_expr E (toRMap Gamma) (toREval (toRExp f)) vR REAL /\ *)
(* (Q2R (fst iv) <= vR <= Q2R (snd iv))%R. *)
validRanges f A E Gamma fBits.
Proof.
induction f;
intros valid_bounds valid_definedVars usedVars_subset valid_freeVars types_defined;
......@@ -182,7 +178,7 @@ Proof.
+ unfold perturb; simpl; lra.
- Flover_compute; simpl in *; try congruence.
unfold validRanges in IHf.
assert (validRanges f A E Gamma) as valid_e.
assert (validRanges f A E Gamma fBits) as valid_e.
{ apply IHf; auto. }
split; try auto.
apply validRanges_single in valid_e.
......@@ -238,9 +234,9 @@ Proof.
}
rewrite <- Q2R0_is_0 in H3.
apply Rlt_Qlt in H3. lra. }
- assert (validRanges f1 A E Gamma) as valid_f1
- assert (validRanges f1 A E Gamma fBits) as valid_f1
by (Flover_compute; try congruence; apply IHf1; try auto; set_tac).
assert (validRanges f2 A E Gamma) as valid_f2
assert (validRanges f2 A E Gamma fBits) as valid_f2
by (Flover_compute; try congruence; apply IHf2; try auto; set_tac).
repeat split;
[ intros; subst; Flover_compute; congruence |
......@@ -250,16 +246,14 @@ Proof.
destruct valid_f1 as [iv_f1 [err1 [vF1 [env1 [eval_f1 valid_f1]]]]].
destruct valid_f2 as [iv_f2 [err2 [vF2 [env2 [eval_f2 valid_f2]]]]].
Flover_compute; try congruence.
assert (REAL = join REAL REAL) as REAL_join by (cbv; auto);
rewrite REAL_join.
kill_trivial_exists.
exists (perturb (evalBinop b vF1 vF2) REAL 0);
split; [destruct i; auto | ].
inversion env1; inversion env2; subst.
destruct b; simpl in *.
* split;
[eapply Binop_dist' with (delta := 0%R); eauto; try congruence;
rewrite Rabs_R0; cbn; lra|].
[eapply Binop_dist' with (delta := 0%R) (fBit:=0%nat); eauto; try congruence;
try rewrite Rabs_R0; cbn; lra|].
pose proof (interval_addition_valid ((Q2R (fst iv_f1)), Q2R (snd iv_f1))
(Q2R (fst iv_f2), Q2R (snd iv_f2)))
as valid_add.
......@@ -271,8 +265,8 @@ Proof.
rewrite <- Q2R_min4, <- Q2R_max4 in *.