Commit 7dd4f12f authored by Nikita Zyuzin's avatar Nikita Zyuzin

Merge branch 'certificates' of https://gitlab.mpi-sws.org/AVA/daisy into fma_proofs_merge

Conflicts:
	coq/ErrorValidation.v
	coq/Expressions.v
	coq/FPRangeValidator.v
	coq/IEEE_connection.v
	coq/Infra/Ltacs.v
	coq/IntervalValidation.v
	coq/Typing.v
parents 5bbb6b4a 13ae6d87
...@@ -112,7 +112,7 @@ $ git submodule init ...@@ -112,7 +112,7 @@ $ git submodule init
Then, initialize the CakeML submodule and start compilation: Then, initialize the CakeML submodule and start compilation:
```bash ```bash
$ git submodule update --recursive --remote $ git submodule update --recursive
$ cd hol4/ $ cd hol4/
$ Holmake $ Holmake
``` ```
......
...@@ -13,9 +13,11 @@ Require Export Daisy.Infra.ExpressionAbbrevs Daisy.Commands. ...@@ -13,9 +13,11 @@ Require Export Daisy.Infra.ExpressionAbbrevs Daisy.Commands.
(** Certificate checking function **) (** Certificate checking function **)
Definition CertificateChecker (e:exp Q) (absenv:analysisResult) (P:precond) (defVars:nat -> option mType) := Definition CertificateChecker (e:exp Q) (absenv:analysisResult) (P:precond) (defVars:nat -> option mType) :=
if (typeCheck e defVars (typeMap defVars e)) then let tMap := (typeMap defVars e (DaisyMap.empty mType)) in
if (validIntervalbounds e absenv P NatSet.empty) && FPRangeValidator e absenv (typeMap defVars e) NatSet.empty if (typeCheck e defVars tMap)
then (validErrorbound e (typeMap defVars e) absenv NatSet.empty) then
if (validIntervalbounds e absenv P NatSet.empty) && FPRangeValidator e absenv tMap NatSet.empty
then (validErrorbound e tMap absenv NatSet.empty)
else false else false
else false. else false.
...@@ -27,19 +29,20 @@ Definition CertificateChecker (e:exp Q) (absenv:analysisResult) (P:precond) (def ...@@ -27,19 +29,20 @@ Definition CertificateChecker (e:exp Q) (absenv:analysisResult) (P:precond) (def
Theorem Certificate_checking_is_sound (e:exp Q) (absenv:analysisResult) P defVars: Theorem Certificate_checking_is_sound (e:exp Q) (absenv:analysisResult) P defVars:
forall (E1 E2:env), forall (E1 E2:env),
approxEnv E1 defVars absenv (usedVars e) NatSet.empty E2 -> approxEnv E1 defVars absenv (usedVars e) NatSet.empty E2 ->
(forall v, NatSet.mem v (Expressions.usedVars e) = true -> (forall v, NatSet.In v (Expressions.usedVars e) ->
exists vR, E1 v = Some vR /\ exists vR, E1 v = Some vR /\
(Q2R (fst (P v)) <= vR <= Q2R (snd (P v)))%R) -> (Q2R (fst (P v)) <= vR <= Q2R (snd (P v)))%R) ->
(forall v, (v) mem (usedVars e) = true -> (forall v, NatSet.In v (usedVars e) ->
exists m : mType, exists m : mType,
defVars v = Some m) -> defVars v = Some m) ->
CertificateChecker e absenv P defVars = true -> CertificateChecker e absenv P defVars = true ->
exists vR vF m, exists iv err vR vF m,
eval_exp E1 (toRMap defVars) (toREval (toRExp e)) vR M0 /\ DaisyMap.find e absenv = Some (iv, err) /\
eval_exp E2 defVars (toRExp e) vF m /\ eval_exp E1 (toRMap defVars) (toREval (toRExp e)) vR M0 /\
(forall vF m, eval_exp E2 defVars (toRExp e) vF m /\
eval_exp E2 defVars (toRExp e) vF m -> (forall vF m,
(Rabs (vR - vF) <= Q2R (snd (absenv e))))%R. eval_exp E2 defVars (toRExp e) vF m ->
(Rabs (vR - vF) <= Q2R err))%R.
(** (**
The proofs is a simple composition of the soundness proofs for the range The proofs is a simple composition of the soundness proofs for the range
validator and the error bound validator. validator and the error bound validator.
...@@ -49,55 +52,52 @@ Proof. ...@@ -49,55 +52,52 @@ Proof.
unfold CertificateChecker in certificate_valid. unfold CertificateChecker in certificate_valid.
rewrite <- andb_lazy_alt in certificate_valid. rewrite <- andb_lazy_alt in certificate_valid.
andb_to_prop certificate_valid. andb_to_prop certificate_valid.
env_assert absenv e env_e.
destruct env_e as [iv [err absenv_eq]].
destruct iv as [ivlo ivhi].
rewrite absenv_eq; simpl.
pose proof (NatSetProps.empty_union_2 (Expressions.usedVars e) NatSet.empty_spec) as union_empty. pose proof (NatSetProps.empty_union_2 (Expressions.usedVars e) NatSet.empty_spec) as union_empty.
hnf in union_empty. hnf in union_empty.
assert (forall v1, (v1) mem (Expressions.usedVars e NatSet.empty) = true -> assert (dVars_range_valid NatSet.empty E1 absenv).
exists m0 : mType, defVars v1 = Some m0). { unfold dVars_range_valid.
{ intros; eapply types_defined. intros; set_tac. }
rewrite NatSet.mem_spec in *.
rewrite <- union_empty; eauto. }
assert (NatSet.Subset (usedVars e -- NatSet.empty) (Expressions.usedVars e)). assert (NatSet.Subset (usedVars e -- NatSet.empty) (Expressions.usedVars e)).
{ hnf; intros a in_empty. { hnf; intros a in_empty.
set_tac. } set_tac. }
assert (vars_typed (usedVars e NatSet.empty) defVars).
{ unfold vars_typed. intros; apply types_defined. set_tac. destruct H1; set_tac.
split; try auto. hnf; intros; set_tac. }
rename R into validFPRanges. rename R into validFPRanges.
assert (forall v, (v) mem (NatSet.empty) = true -> exists vR :R, E1 v = Some vR /\ (Q2R (fst (fst (absenv (Var Q v)))) <= vR <= Q2R (snd (fst (absenv (Var Q v)))))%R). edestruct (validIntervalbounds_sound e (A:=absenv) (P:=P) (fVars:=usedVars e) (dVars:=NatSet.empty) (Gamma:=defVars) (E:=E1))
{ intros v v_in_empty. as [iv_e [ err_e [vR [ map_e [eval_real real_bounds_e]]]]]; eauto.
rewrite NatSet.mem_spec in v_in_empty. destruct iv_e as [elo ehi].
inversion v_in_empty. } edestruct (validErrorbound_sound e (typeMap defVars e (DaisyMap.empty mType)) L approxE1E2 H0 eval_real R0 L1 H P_valid H1 map_e) as [[vF [mF eval_float]] err_bounded]; auto.
edestruct validIntervalbounds_sound as [vR [eval_real real_bounds_e]]; eauto. exists (elo, ehi), err_e, vR, vF, mF; split; auto.
destruct (validErrorbound_sound e P (typeMap defVars e) L approxE1E2 H0 eval_real R0 L1 H1 P_valid H absenv_eq) as [[vF [mF eval_float]] err_bounded]; auto.
exists vR; exists vF; exists mF; split; auto.
Qed. Qed.
Definition CertificateCheckerCmd (f:cmd Q) (absenv:analysisResult) (P:precond) defVars:= Definition CertificateCheckerCmd (f:cmd Q) (absenv:analysisResult) (P:precond) defVars:=
if (typeCheckCmd f defVars (typeMapCmd defVars f) && validSSA f (freeVars f)) let tMap := typeMapCmd defVars f (DaisyMap.empty mType) in
if (typeCheckCmd f defVars tMap && validSSA f (freeVars f))
then then
if (validIntervalboundsCmd f absenv P NatSet.empty) && if (validIntervalboundsCmd f absenv P NatSet.empty) &&
FPRangeValidatorCmd f absenv (typeMapCmd defVars f) NatSet.empty FPRangeValidatorCmd f absenv tMap NatSet.empty
then (validErrorboundCmd f (typeMapCmd defVars f) absenv NatSet.empty) then (validErrorboundCmd f tMap absenv NatSet.empty)
else false else false
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:
forall (E1 E2:env), forall (E1 E2:env),
approxEnv E1 defVars absenv (freeVars f) NatSet.empty E2 -> approxEnv E1 defVars absenv (freeVars f) NatSet.empty E2 ->
(forall v, NatSet.mem v (freeVars f)= true -> (forall v, NatSet.In v (freeVars f) ->
exists vR, E1 v = Some vR /\ exists vR, E1 v = Some vR /\
(Q2R (fst (P v)) <= vR <= Q2R (snd (P v)))%R) -> (Q2R (fst (P v)) <= vR <= Q2R (snd (P v)))%R) ->
(forall v, (v) mem (freeVars f) = true -> (forall v, NatSet.In v (freeVars f) ->
exists m : mType, exists m : mType,
defVars v = Some m) -> defVars v = Some m) ->
CertificateCheckerCmd f absenv P defVars = true -> CertificateCheckerCmd f absenv P defVars = true ->
exists vR vF m, exists iv err vR vF m,
DaisyMap.find (getRetExp f) absenv = Some (iv,err) /\
bstep (toREvalCmd (toRCmd f)) E1 (toRMap defVars) vR M0 /\ bstep (toREvalCmd (toRCmd f)) E1 (toRMap defVars) vR M0 /\
bstep (toRCmd f) E2 defVars vF m /\ bstep (toRCmd f) E2 defVars vF m /\
(forall vF m, (forall vF m,
bstep (toRCmd f) E2 defVars vF m -> bstep (toRCmd f) E2 defVars vF m ->
(Rabs (vR - vF) <= Q2R (snd (absenv (getRetExp f))))%R). (Rabs (vR - vF) <= Q2R (err))%R).
(** (**
The proofs is a simple composition of the soundness proofs for the range The proofs is a simple composition of the soundness proofs for the range
validator and the error bound validator. validator and the error bound validator.
...@@ -109,32 +109,25 @@ Proof. ...@@ -109,32 +109,25 @@ Proof.
andb_to_prop certificate_valid. andb_to_prop certificate_valid.
apply validSSA_sound in R0. apply validSSA_sound in R0.
destruct R0 as [outVars ssa_f]. destruct R0 as [outVars ssa_f].
env_assert absenv (getRetExp f) env_f.
destruct env_f as [iv [err absenv_eq]].
destruct iv as [ivlo ivhi].
assert (ssa f (freeVars f NatSet.empty) outVars) as ssa_valid. assert (ssa f (freeVars f NatSet.empty) outVars) as ssa_valid.
{ eapply ssa_equal_set; try eauto. { eapply ssa_equal_set; try eauto.
apply NatSetProps.empty_union_2. apply NatSetProps.empty_union_2.
apply NatSet.empty_spec. } apply NatSet.empty_spec. }
rename R into validFPRanges. rename R into validFPRanges.
assert (forall v, (v) mem (NatSet.empty) = true -> assert (dVars_range_valid NatSet.empty E1 absenv).
exists vR : R, { unfold dVars_range_valid.
E1 v = Some vR /\ (Q2R (fst (fst (absenv (Var Q v)))) <= vR <= Q2R (snd (fst (absenv (Var Q v)))))%R) as no_dVars_valid. intros; set_tac. }
{ intros v v_in_empty. assert (vars_typed (freeVars f NatSet.empty) defVars).
set_tac. inversion v_in_empty. } { unfold vars_typed. intros; apply types_defined. set_tac.
assert (forall v, (v) mem (freeVars f NatSet.empty) = true -> destruct H0; set_tac. }
exists m : mType, defVars v = Some m) as types_valid.
{ intros v v_mem; apply types_defined.
set_tac. rewrite NatSet.union_spec in v_mem.
destruct v_mem; try auto.
inversion H. }
assert (NatSet.Subset (freeVars f -- NatSet.empty) (freeVars f)) assert (NatSet.Subset (freeVars f -- NatSet.empty) (freeVars f))
as freeVars_contained by set_tac. as freeVars_contained by set_tac.
edestruct (validIntervalboundsCmd_sound) as [vR [eval_real bounded_real_f]] ; eauto. edestruct (validIntervalboundsCmd_sound)
rewrite absenv_eq; simpl. as [iv [ err [vR [map_f [eval_real bounded_real_f]]]]]; eauto.
destruct iv as [f_lo f_hi].
edestruct validErrorboundCmd_gives_eval as [vF [mF eval_float]]; eauto. edestruct validErrorboundCmd_gives_eval as [vF [mF eval_float]]; eauto.
exists vR; exists vF; exists mF; split; try auto. exists (f_lo, f_hi), err, vR, vF, mF; split; try auto.
split; try auto. split; try auto; split; try auto.
intros. intros.
eapply validErrorboundCmd_sound; eauto. eapply validErrorboundCmd_sound; eauto.
Qed. Qed.
\ No newline at end of file
...@@ -20,124 +20,113 @@ Inductive approxEnv : env -> (nat -> option mType) -> analysisResult -> NatSet.t ...@@ -20,124 +20,113 @@ Inductive approxEnv : env -> (nat -> option mType) -> analysisResult -> NatSet.t
(Rabs (v1 - v2) <= (Rabs v1) * Q2R (mTypeToQ m))%R -> (Rabs (v1 - v2) <= (Rabs v1) * Q2R (mTypeToQ m))%R ->
NatSet.mem x (NatSet.union fVars dVars) = false -> NatSet.mem x (NatSet.union fVars dVars) = false ->
approxEnv (updEnv x v1 E1) (updDefVars x m defVars) A (NatSet.add x fVars) dVars (updEnv x v2 E2) approxEnv (updEnv x v1 E1) (updDefVars x m defVars) A (NatSet.add x fVars) dVars (updEnv x v2 E2)
|approxUpdBound E1 E2 defVars A v1 v2 x fVars dVars m: |approxUpdBound E1 E2 defVars A v1 v2 x fVars dVars m iv err:
approxEnv E1 defVars A fVars dVars E2 -> approxEnv E1 defVars A fVars dVars E2 ->
(Rabs (v1 - v2) <= Q2R (snd (A (Var Q x))))%R -> DaisyMap.find (Var Q x) A = Some (iv, err) ->
(Rabs (v1 - v2) <= Q2R err)%R ->
NatSet.mem x (NatSet.union fVars dVars) = false -> NatSet.mem x (NatSet.union fVars dVars) = false ->
approxEnv (updEnv x v1 E1) (updDefVars x m defVars) A fVars (NatSet.add x dVars) (updEnv x v2 E2). approxEnv (updEnv x v1 E1) (updDefVars x m defVars) A fVars (NatSet.add x dVars) (updEnv x v2 E2).
(* Inductive approxParams :env -> env -> Prop := *)
(* |approxParamRefl: *)
(* approxParams emptyEnv emptyEnv *)
(* |approxParamUpd E1 E2 m x v1 v2 : *)
(* approxParams E1 E2 -> *)
(* (Rabs (v1 - v2) <= Q2R (meps m))%R -> *)
(* approxParams (updEnv x M0 v1 E1) (updEnv x m v2 E2). *)
Section RelationProperties. Section RelationProperties.
Variable (x:nat) (v:R) (E1 E2:env) (Gamma:nat -> option mType) (A:analysisResult) (fVars dVars: NatSet.t). Variable (x:nat) (v:R) (E1 E2:env) (Gamma:nat -> option mType)
(A:analysisResult) (fVars dVars: NatSet.t).
Hypothesis approxEnvs: approxEnv E1 Gamma A fVars dVars E2. Hypothesis approxEnvs: approxEnv E1 Gamma A fVars dVars E2.
Lemma approxEnv_gives_value: Lemma approxEnv_gives_value:
E1 x = Some v -> E1 x = Some v ->
NatSet.In x (NatSet.union fVars dVars) -> NatSet.In x (NatSet.union fVars dVars) ->
exists v', exists v',
E2 x = Some v'. E2 x = Some v'.
Proof. Proof.
induction approxEnvs; induction approxEnvs;
intros E1_def x_valid. intros E1_def x_valid.
- unfold emptyEnv in E1_def; simpl in E1_def. congruence. - unfold emptyEnv in E1_def; simpl in E1_def. congruence.
- unfold updEnv in *. - unfold updEnv in *.
case_eq (x =? x0); intros eq_case; rewrite eq_case in *. case_eq (x =? x0); intros eq_case; rewrite eq_case in *.
+ eexists; eauto. + eexists; eauto.
+ eapply IHa; auto. + eapply IHa; eauto.
set_tac. set_tac.
rewrite NatSet.union_spec in x_valid. destruct x_valid; set_tac.
destruct x_valid; set_tac. destruct H1 as [? | [? ?]]; subst; try auto.
rewrite NatSet.add_spec in H1. rewrite Nat.eqb_refl in eq_case; congruence.
destruct H1; subst; try auto. - unfold updEnv in *.
rewrite Nat.eqb_refl in eq_case; congruence. case_eq (x =? x0); intros eq_case; rewrite eq_case in *.
- unfold updEnv in *. + eexists; eauto.
case_eq (x =? x0); intros eq_case; rewrite eq_case in *. + eapply IHa; auto.
+ eexists; eauto. set_tac.
+ eapply IHa; auto. destruct x_valid; set_tac.
set_tac. destruct H2 as [? | [ ? ?]]; subst; try auto.
rewrite NatSet.union_spec in x_valid. rewrite Nat.eqb_refl in eq_case; congruence.
destruct x_valid; set_tac. Qed.
rewrite NatSet.add_spec in H1.
destruct H1; subst; try auto.
rewrite Nat.eqb_refl in eq_case; congruence.
Qed.
Arguments mTypeToQ _ : simpl nomatch. Arguments mTypeToQ _ : simpl nomatch.
Lemma approxEnv_fVar_bounded v2 m: Lemma approxEnv_fVar_bounded v2 m:
E1 x = Some v -> E1 x = Some v ->
E2 x = Some v2 -> E2 x = Some v2 ->
NatSet.In x fVars -> NatSet.In x fVars ->
Gamma x = Some m -> Gamma x = Some m ->
(Rabs (v - v2) <= (Rabs v) * Q2R (mTypeToQ m))%R. (Rabs (v - v2) <= (Rabs v) * Q2R (mTypeToQ m))%R.
Proof. Proof.
induction approxEnvs; induction approxEnvs;
intros E1_def E2_def x_free x_typed. intros E1_def E2_def x_free x_typed.
- unfold emptyEnv in *; simpl in *; congruence. - unfold emptyEnv in *; simpl in *; congruence.
- set_tac. - set_tac.
rewrite add_spec_strong in x_free. destruct x_free as [x_x0 | [x_neq x_free]]; subst.
destruct x_free as [x_x0 | [x_neq x_free]]; subst. + unfold updEnv in *;
+ unfold updEnv in *; rewrite Nat.eqb_refl in *; simpl in *.
rewrite Nat.eqb_refl in *; simpl in *. unfold updDefVars in x_typed.
unfold updDefVars in x_typed. rewrite Nat.eqb_refl in x_typed.
rewrite Nat.eqb_refl in x_typed. inversion x_typed; subst.
inversion x_typed; subst. inversion E1_def; inversion E2_def; subst; auto.
inversion E1_def; inversion E2_def; subst; auto. + unfold updEnv in *; simpl in *.
+ unfold updEnv in *; simpl in *. rewrite <- Nat.eqb_neq in x_neq.
rewrite <- Nat.eqb_neq in x_neq. rewrite x_neq in *; simpl in *.
rewrite x_neq in *; simpl in *. unfold updDefVars in x_typed; rewrite x_neq in x_typed.
unfold updDefVars in x_typed; rewrite x_neq in x_typed. apply IHa; auto.
- assert (x =? x0 = false) as x_x0_neq.
{ rewrite Nat.eqb_neq; hnf; intros; subst.
set_tac.
apply H1.
set_tac. }
unfold updEnv in *; rewrite x_x0_neq in *.
apply IHa; auto. apply IHa; auto.
- assert (x =? x0 = false) as x_x0_neq. unfold updDefVars in x_typed;
{ rewrite Nat.eqb_neq; hnf; intros; subst. rewrite x_x0_neq in x_typed; auto.
set_tac. Qed.
apply H0.
set_tac. }
unfold updEnv in *; rewrite x_x0_neq in *.
apply IHa; auto.
unfold updDefVars in x_typed;
rewrite x_x0_neq in x_typed; auto.
Qed.
Lemma approxEnv_dVar_bounded v2 m e: Lemma approxEnv_dVar_bounded v2 m iv e:
E1 x = Some v -> E1 x = Some v ->
E2 x = Some v2 -> E2 x = Some v2 ->
NatSet.In x dVars -> NatSet.In x dVars ->
Gamma x = Some m -> Gamma x = Some m ->
snd (A (Var Q x)) = e -> DaisyMap.find (Var Q x) A = Some (iv, e) ->
(Rabs (v - v2) <= Q2R e)%R. (Rabs (v - v2) <= Q2R e)%R.
Proof. Proof.
induction approxEnvs; induction approxEnvs;
intros E1_def E2_def x_def x_typed A_e; subst. intros E1_def E2_def x_def x_typed A_e; subst.
- unfold emptyEnv in *; simpl in *; congruence. - unfold emptyEnv in *; simpl in *; congruence.
- assert (x =? x0 = false) as x_x0_neq. - assert (x =? x0 = false) as x_x0_neq.
{ rewrite Nat.eqb_neq; hnf; intros; subst. { rewrite Nat.eqb_neq; hnf; intros; subst.
set_tac. set_tac.
apply H0; set_tac. apply H0; set_tac.
} }
unfold updEnv in *; rewrite x_x0_neq in *. unfold updEnv in *; rewrite x_x0_neq in *.
unfold updDefVars in x_typed; rewrite x_x0_neq in x_typed. unfold updDefVars in x_typed; rewrite x_x0_neq in x_typed.
apply IHa; auto.
- set_tac.
rewrite add_spec_strong in x_def.
destruct x_def as [x_x0 | [x_neq x_def]]; subst.
+ unfold updEnv in *;
rewrite Nat.eqb_refl in *; simpl in *.
inversion E1_def; inversion E2_def; subst; auto.
+ unfold updEnv in *; simpl in *.
rewrite <- Nat.eqb_neq in x_neq.
rewrite x_neq in *; simpl in *.
unfold updDefVars in x_typed; rewrite x_neq in x_typed.
apply IHa; auto. apply IHa; auto.
Qed. - set_tac.
destruct x_def as [x_x0 | [x_neq x_def]]; subst.
+ unfold updEnv in *;
rewrite Nat.eqb_refl in *; simpl in *.
inversion E1_def; inversion E2_def; subst.
rewrite A_e in *; inversion H; auto.
+ unfold updEnv in *; simpl in *.
rewrite <- Nat.eqb_neq in x_neq.
rewrite x_neq in *; simpl in *.
unfold updDefVars in x_typed; rewrite x_neq in x_typed.
apply IHa; auto.
Qed.
End RelationProperties. End RelationProperties.
\ No newline at end of file
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
...@@ -62,3 +62,15 @@ Definition updEnv (x:nat) (v: R) (E:env) (y:nat) := ...@@ -62,3 +62,15 @@ Definition updEnv (x:nat) (v: R) (E:env) (y:nat) :=
Definition updDefVars (x:nat) (m:mType) (defVars:nat -> option mType) (y:nat) := Definition updDefVars (x:nat) (m:mType) (defVars:nat -> option mType) (y:nat) :=
if (y =? x) then Some m else defVars y. if (y =? x) then Some m else defVars y.
Definition optionLift (V T:Type) (v:option V) default (f: V -> T) :=
match v with
| None => default
| Some val => f val
end.
Ltac optionD :=
match goal with
|H: context[optionLift ?v ?default ?f] |- _ =>
destruct ?v eqn:?
end.
\ No newline at end of file
...@@ -2,11 +2,20 @@ ...@@ -2,11 +2,20 @@
Some abbreviations that require having defined expressions beforehand Some abbreviations that require having defined expressions beforehand
If we would put them in the Abbrevs file, this would create a circular dependency which Coq cannot resolve. 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. Require Import Coq.QArith.QArith Coq.Reals.Reals Coq.QArith.Qreals Coq.QArith.QOrderedType Coq.FSets.FMapAVL Coq.FSets.FMapFacts.
Require Export Daisy.Infra.Abbrevs Daisy.Expressions. Require Export Daisy.Infra.Abbrevs Daisy.Expressions.
Module Q_orderedExps := ExpOrderedType (Q_as_OT).
Module legacy_OrderedQExps := Structures.OrdersAlt.Backport_OT (Q_orderedExps).
Module DaisyMap := FMapAVL.Make(legacy_OrderedQExps).
Module DaisyMapFacts := OrdProperties (DaisyMap).
Definition analysisResult :Type := DaisyMap.t (intv * error).
(** (**
We treat a function mapping an expression arguing on fractions as value type We treat a function mapping an expression arguing on fractions as value type
to pairs of intervals on rationals and rational errors as the analysis result to pairs of intervals on rationals and rational errors as the analysis result
**) **)
Definition analysisResult :Type := exp Q -> intv * error. (* Definition analysisResult :Type := exp Q -> intv * error. *)
\ No newline at end of file \ No newline at end of file
...@@ -21,11 +21,13 @@ Ltac canonize_Q_prop := ...@@ -21,11 +21,13 @@ Ltac canonize_Q_prop :=
match goal with match goal with
| [ H: Qle_bool ?a ?b = true |- _] => rewrite Qle_bool_iff in H | [ H: Qle_bool ?a ?b = true |- _] => rewrite Qle_bool_iff in H
| [ H: Qleb ?a ?b = true |- _ ] => rewrite Qle_bool_iff in H | [ H: Qleb ?a ?b = true |- _ ] => rewrite Qle_bool_iff in H
| [ H: Qeq_bool ?a ?b = true |- _] => rewrite Qeq_bool_iff in H
end. end.
Ltac canonize_Q_to_R := Ltac canonize_Q_to_R :=
match goal with match goal with
| [ H: (?a <= ?b)%Q |- _ ] => apply Qle_Rle in H | [ H: (?a <= ?b)%Q |- _ ] => apply Qle_Rle in H
| [ H: (?a == ?b)%Q |- _ ] => apply Qeq_eqR in H
| [ H: context [Q2R 0] |- _ ] => rewrite Q2R0_is_0 in H | [ H: context [Q2R 0] |- _ ] => rewrite Q2R0_is_0 in H
| [ |- context [Q2R 0] ] => rewrite Q2R0_is_0 | [ |- context [Q2R 0] ] => rewrite Q2R0_is_0
end. end.
...@@ -44,96 +46,116 @@ Ltac Q2R_to_head_step := ...@@ -44,96 +46,116 @@ Ltac Q2R_to_head_step :=
Ltac Q2R_to_head := repeat Q2R_to_head_step. Ltac Q2R_to_head := repeat Q2R_to_head_step.
Ltac NatSet_simp hyp :=
try rewrite NatSet.mem_spec in hyp;
try rewrite NatSet.equal_spec in hyp;
try rewrite NatSet.subset_spec in hyp;
try rewrite NatSet.empty_spec in hyp;
try rewrite NatSet.is_empty_spec in hyp;
try rewrite NatSet.add_spec in hyp;
try rewrite NatSet.remove_spec in hyp;
try rewrite NatSet.singleton_spec in hyp;
try rewrite NatSet.union_spec in hyp;
try rewrite NatSet.inter_spec in hyp;
try rewrite NatSet.diff_spec in hyp.
Ltac NatSet_prop :=
match goal with
| [ H : true = true |- _ ] => clear H; NatSet_prop
| [ H: ?T = true |- _ ] => NatSet_simp H;
(apply Is_true_eq_left in H; NatSet_prop; apply Is_true_eq_true in H) || NatSet_prop
| _ => try auto
end.
Ltac destruct_if :=
match goal with
| [H: (if ?c then ?a else ?b) = _ |- _ ] =>
case_eq ?c;
let name := fresh "cond" in
intros name;
rewrite name in *;
try congruence
end.
Definition optionLift (X Y:Type) (v:option X) (f:X -> Y) (e:Y) := Definition optionLift (X Y:Type) (v:option X) (f:X -> Y) (e:Y) :=
match v with match v with
|Some val => f val |Some val => f val
| None => e | None => e
end. end.
Lemma optionLift_eq (X Y:Type) v (f:X -> Y) (e:Y): Lemma optionLift_eq (X Y:Type) v (f:X -> Y) (e:Y):
match v with |Some val => f val | None => e end = optionLift X Y v f e. match v with |Some val => f val | None => e end = optionLift X Y v f e.
Proof. Proof.
cbv; auto. reflexivity.
Qed. Qed.
Lemma optionLift_cond X (a:bool) (b c :X): Lemma optionLift_cond X (a:bool) (b c :X):
(if a then b else c) = match a with |true => b |false => c end. (if a then b else c) = match a with |true => b |false => c end.
Proof. Proof.
cbv; auto. reflexivity.
Qed. Qed.
Ltac remove_matches := rewrite optionLift_eq in *. Ltac remove_matches := rewrite optionLift_eq in *.
Ltac remove_conds := rewrite <- andb_lazy_alt, optionLift_cond in *. Ltac remove_conds := rewrite <- andb_lazy_alt, optionLift_cond in *.
Ltac match_factorize_asm :=