Commit 96bc2e7e authored by Heiko Becker's avatar Heiko Becker

minor style changes in Coq dev and finish porting in HOL4

parent 858e91ae
...@@ -26,7 +26,7 @@ Inductive approxEnv : env -> (expr R -> option mType) -> analysisResult -> NatSe ...@@ -26,7 +26,7 @@ Inductive approxEnv : env -> (expr R -> option mType) -> analysisResult -> NatSe
(Rabs (v1 - v2) <= computeErrorR v1 m)%R -> (Rabs (v1 - v2) <= computeErrorR v1 m)%R ->
NatSet.mem x (NatSet.union fVars dVars) = false -> NatSet.mem x (NatSet.union fVars dVars) = false ->
approxEnv (updEnv x v1 E1) approxEnv (updEnv x v1 E1)
(updDefVars (Var R x) m Gamma) A (NatSet.add x fVars) dVars Gamma A (NatSet.add x fVars) dVars
(updEnv x v2 E2) (updEnv x v2 E2)
|approxUpdBound E1 E2 Gamma A v1 v2 x fVars dVars m iv err: |approxUpdBound E1 E2 Gamma A v1 v2 x fVars dVars m iv err:
approxEnv E1 Gamma A fVars dVars E2 -> approxEnv E1 Gamma A fVars dVars E2 ->
...@@ -88,11 +88,7 @@ Section RelationProperties. ...@@ -88,11 +88,7 @@ Section RelationProperties.
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. congruence.
cbn in x_typed.
rewrite Nat.compare_refl in x_typed.
inversion x_typed; subst.
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 *.
...@@ -109,7 +105,6 @@ Section RelationProperties. ...@@ -109,7 +105,6 @@ Section RelationProperties.
apply H2. apply H2.
set_tac. } set_tac. }
unfold updEnv in *; rewrite x_x0_neq in *. unfold updEnv in *; rewrite x_x0_neq in *.
unfold updDefVars in x_typed.
cbn in x_typed. cbn in x_typed.
apply Nat.eqb_neq in x_x0_neq. apply Nat.eqb_neq in x_x0_neq.
destruct (x ?= x0)%nat eqn:?. destruct (x ?= x0)%nat eqn:?.
......
...@@ -249,12 +249,11 @@ Proof. ...@@ -249,12 +249,11 @@ Proof.
rewrite Rabs_R0. auto using mTypeToR_pos_R. rewrite Rabs_R0. auto using mTypeToR_pos_R.
Qed. Qed.
Lemma validErrorboundCorrectConstant E1 E2 A m n nR nF e nlo nhi dVars exprTypes Lemma validErrorboundCorrectConstant E1 E2 A m n nR nF e nlo nhi dVars Gamma:
Gamma:
eval_Real E1 Gamma (Const m n) nR -> eval_Real E1 Gamma (Const m n) nR ->
eval_Fin E2 Gamma (Const m n) nF m -> eval_Fin E2 Gamma (Const m n) nF m ->
validTypes (Const m n) Gamma -> validTypes (Const m n) Gamma ->
validErrorbound (Const m n) exprTypes A dVars = true -> validErrorbound (Const m n) Gamma A dVars = true ->
(Q2R nlo <= nR <= Q2R nhi)%R -> (Q2R nlo <= nR <= Q2R nhi)%R ->
FloverMap.find (Const m n) A = Some ((nlo,nhi),e) -> FloverMap.find (Const m n) A = Some ((nlo,nhi),e) ->
(Rabs (nR - nF) <= (Q2R e))%R. (Rabs (nR - nF) <= (Q2R e))%R.
...@@ -275,28 +274,6 @@ Proof. ...@@ -275,28 +274,6 @@ Proof.
simpl in *; auto. simpl in *; auto.
Qed. Qed.
(*
Lemma isFixedPoint_lift m1 m2 e fBits f:
(isFixedPoint m1 -> isFixedPoint m2 -> FloverMap.find e fBits = Some f) ->
isFixedPoint m1 -> isFixedPoint m2 -> toRBMap fBits (toRExp e) = Some f.
Proof.
intros isvalid fixed_m1 fixed_m2.
apply toRBMap_some.
auto.
Qed.
Lemma isFixedPoint_lift3 m1 m2 m3 e fBits f:
(isFixedPoint m1 -> isFixedPoint m2 -> isFixedPoint m3 ->
FloverMap.find e fBits = Some f) ->
isFixedPoint m1 -> isFixedPoint m2 -> isFixedPoint m3 ->
toRBMap fBits (toRExp e) = Some f.
Proof.
intros isvalid fixed_m1 fixed_m2 fixed_m3.
apply toRBMap_some.
auto.
Qed.
*)
Lemma validErrorboundCorrectAddition E1 E2 A Lemma validErrorboundCorrectAddition E1 E2 A
(e1:expr Q) (e2:expr Q) (nR nR1 nR2 nF nF1 nF2 :R) (e err1 err2 :error) (e1:expr Q) (e2:expr Q) (nR nR1 nR2 nF nF1 nF2 :R) (e err1 err2 :error)
(alo ahi e1lo e1hi e2lo e2hi:Q) dVars m m1 m2 Gamma: (alo ahi e1lo e1hi e2lo e2hi:Q) dVars m m1 m2 Gamma:
...@@ -1994,7 +1971,7 @@ Qed. ...@@ -1994,7 +1971,7 @@ Qed.
(** (**
Soundness theorem for the error bound validator. Soundness theorem for the error bound validator.
Proof is by induction on the exprression e. Proof is by induction on the expression e.
Each case requires the application of one of the soundness lemmata proven before Each case requires the application of one of the soundness lemmata proven before
**) **)
Theorem validErrorbound_sound (e:expr Q): Theorem validErrorbound_sound (e:expr Q):
...@@ -2004,7 +1981,6 @@ Theorem validErrorbound_sound (e:expr Q): ...@@ -2004,7 +1981,6 @@ Theorem validErrorbound_sound (e:expr Q):
NatSet.Subset (NatSet.diff (Expressions.usedVars e) dVars) fVars -> NatSet.Subset (NatSet.diff (Expressions.usedVars e) dVars) fVars ->
eval_Real E1 Gamma e nR -> eval_Real E1 Gamma e nR ->
validErrorbound e Gamma A dVars = true -> validErrorbound e Gamma A dVars = true ->
validTypes e Gamma ->
validRanges e A E1 (toRTMap (toRExpMap Gamma)) -> validRanges e A E1 (toRTMap (toRExpMap Gamma)) ->
FloverMap.find e A = Some ((elo,ehi),err) -> FloverMap.find e A = Some ((elo,ehi),err) ->
(exists nF m, (exists nF m,
...@@ -2014,8 +1990,8 @@ Theorem validErrorbound_sound (e:expr Q): ...@@ -2014,8 +1990,8 @@ Theorem validErrorbound_sound (e:expr Q):
(Rabs (nR - nF) <= (Q2R err))%R). (Rabs (nR - nF) <= (Q2R err))%R).
Proof. Proof.
revert e; induction e; revert e; induction e;
intros * typing_ok approxCEnv fVars_subset eval_real valid_error valid_types intros * typing_ok approxCEnv fVars_subset eval_real valid_error valid_intv
valid_intv A_eq. A_eq.
- split. - split.
+ eapply validErrorboundCorrectVariable_eval; eauto. + eapply validErrorboundCorrectVariable_eval; eauto.
+ intros * eval_float. eapply validErrorboundCorrectVariable; eauto. + intros * eval_float. eapply validErrorboundCorrectVariable; eauto.
...@@ -2336,7 +2312,6 @@ Proof. ...@@ -2336,7 +2312,6 @@ Proof.
{ exists vF_res; exists m_res; try auto. { exists vF_res; exists m_res; try auto.
econstructor; eauto. } econstructor; eauto. }
+ destruct valid_types as [[? [? [? [? [? ?]]]]] ?]; auto. + destruct valid_types as [[? [? [? [? [? ?]]]]] ?]; auto.
+ destruct valid_types as [[? [? [? [? [? ?]]]]] ?]; auto.
+ destruct valid_intv as [[? ?] ?]; auto. + destruct valid_intv as [[? ?] ?]; auto.
- inversion eval_real; subst. - inversion eval_real; subst.
unfold updEnv; simpl. unfold updEnv; simpl.
...@@ -2407,28 +2382,9 @@ Proof. ...@@ -2407,28 +2382,9 @@ Proof.
simpl. simpl.
rewrite NatSet.diff_spec, NatSet.remove_spec, NatSet.union_spec. rewrite NatSet.diff_spec, NatSet.remove_spec, NatSet.union_spec.
split; try auto. split; try auto.
(* + eapply swap_Gamma_bstep with (Gamma1 := updDefVars n REAL (toRTMap Gamma)); *)
(* eauto using Rmap_updVars_comm. *)
(* + apply validRangesCmd_swap with (Gamma1 := updDefVars n REAL Gamma). *)
(* * intros x. *)
(* unfold toRTMap, updDefVars. *)
(* destruct (x =? n) eqn:?; auto. *)
(* * destruct valid_intv as [[? valid_cont] ?]. *)
(* apply valid_cont. *)
(* apply swap_Gamma_eval_expr with (Gamma1 := toRTMap Gamma); try auto. *)
+ destruct valid_intv as [[? ?] ?]; auto. + destruct valid_intv as [[? ?] ?]; auto.
+ destruct valid_types as [[? [? [? [? [? ?]]]]] ?]; auto. + destruct valid_types as [[? [? [? [? [? ?]]]]] ?]; auto.
+ destruct valid_types as [[? [? [? [? [? ?]]]]] ?]; auto.
+ destruct valid_intv as [[? ?] ?]; auto. + destruct valid_intv as [[? ?] ?]; auto.
(* + intros v1 v1_mem; set_tac. *)
(* unfold updDefVars. *)
(* case_eq (v1 =? n); intros case_v1; try rewrite case_v1 in *; try eauto. *)
(* apply types_defined. *)
(* rewrite NatSet.union_spec. *)
(* destruct v1_mem as [v_fVar | v_dVar]; try auto. *)
(* rewrite NatSet.add_spec in v_dVar. destruct v_dVar; try auto. *)
(* subst; rewrite Nat.eqb_refl in case_v1; congruence. *)
(* + destruct valid_intv as [[? ?] ?]; auto. *)
- inversion eval_real; subst. - inversion eval_real; subst.
inversion eval_float; subst. inversion eval_float; subst.
unfold updEnv; simpl. unfold updEnv; simpl.
......
...@@ -380,7 +380,7 @@ Proof. ...@@ -380,7 +380,7 @@ Proof.
Qed. Qed.
Lemma swap_Gamma_eval_expr e E vR m Gamma1 Gamma2: Lemma swap_Gamma_eval_expr e E vR m Gamma1 Gamma2:
(forall n, Gamma1 n = Gamma2 n) -> (forall e, Gamma1 e = Gamma2 e) ->
eval_expr E Gamma1 e vR m -> eval_expr E Gamma1 e vR m ->
eval_expr E Gamma2 e vR m. eval_expr E Gamma2 e vR m.
Proof. Proof.
......
...@@ -219,6 +219,32 @@ Proof. ...@@ -219,6 +219,32 @@ Proof.
congruence. congruence.
Qed. Qed.
Lemma map_find_add e1 e2 m map1:
FloverMap.find e1 (FloverMap.add e2 m map1) =
match Q_orderedExps.compare e2 e1 with
|Eq => Some m
|_ => FloverMap.find (elt:=mType) e1 map1
end.
Proof.
rewrite FloverMapFacts.P.F.add_o.
unfold FloverMapFacts.P.F.eq_dec.
unfold Q_orderedExps.compare.
destruct (Q_orderedExps.exprCompare e2 e1) eqn:?; congruence.
Qed.
Lemma map_mem_add e1 e2 m map1:
FloverMap.mem e1 (FloverMap.add e2 m map1) =
match Q_orderedExps.compare e2 e1 with
|Eq => true
| _ => FloverMap.mem (elt:=mType) e1 map1
end.
Proof.
rewrite FloverMapFacts.P.F.mem_find_b.
rewrite map_find_add.
destruct (Q_orderedExps.compare e2 e1) eqn:?; try auto;
rewrite FloverMapFacts.P.F.mem_find_b; auto.
Qed.
Definition toRExpMap (tMap:FloverMap.t mType) : expr R -> option mType := Definition toRExpMap (tMap:FloverMap.t mType) : expr R -> option mType :=
let elements := FloverMap.elements (elt:=mType) tMap in let elements := FloverMap.elements (elt:=mType) tMap in
fun (e:expr R) => fun (e:expr R) =>
...@@ -378,6 +404,66 @@ Proof. ...@@ -378,6 +404,66 @@ Proof.
rewrite Pos.eqb_refl, N.eqb_refl in e5; simpl in *; congruence. rewrite Pos.eqb_refl, N.eqb_refl in e5; simpl in *; congruence.
Qed. Qed.
Lemma no_cycle_unop e:
forall u, Q_orderedExps.exprCompare e (Unop u e) <> Eq.
induction e; intros *; cbn in *; try congruence.
destruct (unopEq u u0) eqn:?; try auto.
destruct (unopEq u Neg); congruence.
Qed.
Lemma no_cycle_cast e:
forall m, Q_orderedExps.exprCompare e (Downcast m e) <> Eq.
induction e; intros *; cbn in *; try congruence.
destruct (mTypeEq m m0) eqn:?; try auto.
destruct m; destruct m0; type_conv; try congruence;
cbn; hnf; intros; try congruence.
destruct (w ?= w0)%positive eqn:?; try congruence.
apply Pos.compare_eq in Heqc.
apply N.compare_eq in H; subst; congruence.
Qed.
Lemma no_cycle_binop_left e1:
forall b e2, Q_orderedExps.exprCompare e1 (Binop b e1 e2) <> Eq.
induction e1; intros *; cbn in *; try congruence.
pose (bOp := b);
destruct b; destruct b0;
try (hnf; intros; congruence);
destruct (Q_orderedExps.exprCompare e1_1 (Binop bOp e1_1 e1_2)) eqn:case_comp;
subst bOp; rewrite case_comp in *;
congruence.
Qed.
Lemma no_cycle_binop_right e2:
forall b e1, Q_orderedExps.exprCompare e2 (Binop b e1 e2) <> Eq.
induction e2; intros *; cbn in *; try congruence.
pose (bOp := b);
destruct b; destruct b0;
try (hnf; intros; congruence);
destruct (Q_orderedExps.exprCompare e2_1 e1) eqn:?; congruence.
Qed.
Lemma no_cycle_fma_left e1:
forall e2 e3, Q_orderedExps.exprCompare e1 (Fma e1 e2 e3) <> Eq.
Proof.
induction e1; intros *; cbn in *; try congruence;
destruct (Q_orderedExps.exprCompare e1_1 (Fma e1_1 e1_2 e1_3)) eqn:?; congruence.
Qed.
Lemma no_cycle_fma_center e2:
forall e1 e3, Q_orderedExps.exprCompare e2 (Fma e1 e2 e3) <> Eq.
Proof.
induction e2; intros *; cbn in *; try congruence.
destruct (Q_orderedExps.exprCompare e2_1 e1) eqn:?; try congruence.
destruct (Q_orderedExps.exprCompare e2_2 (Fma e2_1 e2_2 e2_3)) eqn:?; congruence.
Qed.
Lemma no_cycle_fma_right e3:
forall e1 e2, Q_orderedExps.exprCompare e3 (Fma e1 e2 e3) <> Eq.
Proof.
induction e3; intros *; cbn in *; try congruence.
destruct (Q_orderedExps.exprCompare e3_1 e1) eqn:?; try congruence.
destruct (Q_orderedExps.exprCompare e3_2 e2) eqn:?; try congruence.
Qed.
(* (*
Lemma toRExpMap_toRTMap e Gamma m: Lemma toRExpMap_toRTMap e Gamma m:
toRExpMap Gamma (toRExp e) = Some m -> toRExpMap Gamma (toRExp e) = Some m ->
......
...@@ -57,11 +57,6 @@ Definition mTypeToR (m:mType) :R := ...@@ -57,11 +57,6 @@ Definition mTypeToR (m:mType) :R :=
| M32 => 1/ 2^24 | M32 => 1/ 2^24
| M64 => 1/ 2^53 | M64 => 1/ 2^53
| F w f => 1/ 2^(N.to_nat f) | F w f => 1/ 2^(N.to_nat f)
(*
(* the epsilons below match what is used internally in Daisy,
although these value do not match the IEEE standard *)
| M128 => (Qpower (2#1) (Zneg 105))
| M256 => (Qpower (2#1) (Zneg 211)) *)
end. end.
Definition mTypeToQ (m:mType) :Q := Definition mTypeToQ (m:mType) :Q :=
...@@ -71,11 +66,6 @@ Definition mTypeToQ (m:mType) :Q := ...@@ -71,11 +66,6 @@ Definition mTypeToQ (m:mType) :Q :=
| M32 => (Qpower (2#1) (Zneg 24)) | M32 => (Qpower (2#1) (Zneg 24))
| M64 => (Qpower (2#1) (Zneg 53)) | M64 => (Qpower (2#1) (Zneg 53))
| F w f => Qpower (2#1) (- Z.of_N f) | F w f => Qpower (2#1) (- Z.of_N f)
(*
(* the epsilons below match what is used internally in Daisy,
although these value do not match the IEEE standard *)
| M128 => (Qpower (2#1) (Zneg 105))
| M256 => (Qpower (2#1) (Zneg 211)) *)
end. end.
Definition computeErrorR v m :R := Definition computeErrorR v m :R :=
...@@ -201,8 +191,6 @@ Definition mTypeEq (m1:mType) (m2:mType) := ...@@ -201,8 +191,6 @@ Definition mTypeEq (m1:mType) (m2:mType) :=
| M32, M32 => true | M32, M32 => true
| M64, M64 => true | M64, M64 => true
| F w1 f1, F w2 f2 => (w1 =? w2)%positive && (f1 =? f2)%N | F w1 f1, F w2 f2 => (w1 =? w2)%positive && (f1 =? f2)%N
(* | M128, M128 => true *)
(* | M256, M256 => true *)
| _, _ => false | _, _ => false
end. end.
...@@ -273,8 +261,10 @@ Definition isMorePrecise (m1:mType) (m2:mType) := ...@@ -273,8 +261,10 @@ Definition isMorePrecise (m1:mType) (m2:mType) :=
| _, _ => Qle_bool (mTypeToQ m1) (mTypeToQ m2) | _, _ => Qle_bool (mTypeToQ m1) (mTypeToQ m2)
end. end.
(* More efficient version for performance, unfortunately we cannot do better (**
for fixed-points *) More efficient version for performance, unfortunately we cannot do better
for fixed-points
**)
Definition morePrecise (m1:mType) (m2:mType) := Definition morePrecise (m1:mType) (m2:mType) :=
match m1, m2 with match m1, m2 with
| REAL, _ => true | REAL, _ => true
...@@ -302,10 +292,7 @@ Lemma morePrecise_trans m1 m2 m3: ...@@ -302,10 +292,7 @@ Lemma morePrecise_trans m1 m2 m3:
Proof. Proof.
destruct m1; destruct m2; destruct m3; simpl; auto; destruct m1; destruct m2; destruct m3; simpl; auto;
intros le1 le2; try congruence. intros le1 le2; try congruence.
(* andb_to_prop le1; andb_to_prop le2. *)
apply Pos.leb_le in le1; apply Pos.leb_le in le2. apply Pos.leb_le in le1; apply Pos.leb_le in le2.
(* apply Pos.leb_le in L0; apply Pos.leb_le in R0. *)
(* split_bool; *)
apply Pos.leb_le; apply Pos.leb_le;
eapply Pos.le_trans; eauto. eapply Pos.le_trans; eauto.
Qed. Qed.
......
...@@ -19,10 +19,6 @@ Definition fVars_P_sound (fVars:NatSet.t) (E:env) (P:precond) :Prop := ...@@ -19,10 +19,6 @@ Definition fVars_P_sound (fVars:NatSet.t) (E:env) (P:precond) :Prop :=
exists vR, E v = Some vR /\ exists vR, E v = Some vR /\
(Q2R (fst (P v)) <= vR <= Q2R (snd (P v)))%R. (Q2R (fst (P v)) <= vR <= Q2R (snd (P v)))%R.
Definition vars_typed (S:NatSet.t) (Gamma: nat -> option mType) :=
forall v, NatSet.In v S ->
exists m :mType, Gamma v = Some m.
Ltac kill_trivial_exists := Ltac kill_trivial_exists :=
match goal with match goal with
| [ |- exists iv err v, Some (?i,?e) = Some (iv, err) /\ _ ] => exists i, e | [ |- exists iv err v, Some (?i,?e) = Some (iv, err) /\ _ ] => exists i, e
......
...@@ -29,13 +29,17 @@ Fixpoint validTypes e (Gamma:FloverMap.t mType) :Prop := ...@@ -29,13 +29,17 @@ Fixpoint validTypes e (Gamma:FloverMap.t mType) :Prop :=
| Var _ x => True | Var _ x => True
| Const m v => m = mG | Const m v => m = mG
| Unop u e1 => | Unop u e1 =>
validTypes e1 Gamma /\ exists me, FloverMap.find e1 Gamma = Some me /\ isCompat me mG = true validTypes e1 Gamma /\
exists me, FloverMap.find e1 Gamma = Some me /\ isCompat me mG = true
| Binop b e1 e2 => | Binop b e1 e2 =>
validTypes e1 Gamma /\ validTypes e2 Gamma /\ validTypes e1 Gamma /\
exists m1 m2, FloverMap.find e1 Gamma = Some m1 /\ FloverMap.find e2 Gamma = Some m2 /\ validTypes e2 Gamma /\
exists m1 m2, FloverMap.find e1 Gamma = Some m1 /\
FloverMap.find e2 Gamma = Some m2 /\
isJoin m1 m2 mG = true isJoin m1 m2 mG = true
| Fma e1 e2 e3 => | Fma e1 e2 e3 =>
validTypes e1 Gamma /\ validTypes e2 Gamma /\ validTypes e1 Gamma /\
validTypes e2 Gamma /\
validTypes e3 Gamma /\ validTypes e3 Gamma /\
exists m1 m2 m3, exists m1 m2 m3,
FloverMap.find e1 Gamma = Some m1 /\ FloverMap.find e2 Gamma = Some m2 /\ FloverMap.find e1 Gamma = Some m1 /\ FloverMap.find e2 Gamma = Some m2 /\
...@@ -47,7 +51,8 @@ Fixpoint validTypes e (Gamma:FloverMap.t mType) :Prop := ...@@ -47,7 +51,8 @@ Fixpoint validTypes e (Gamma:FloverMap.t mType) :Prop :=
(FloverMap.find e1 Gamma = Some m1 /\ isMorePrecise m1 mG = true) (FloverMap.find e1 Gamma = Some m1 /\ isMorePrecise m1 mG = true)
end /\ end /\
(forall E Gamma2 v m, (forall E Gamma2 v m,
(forall e m, FloverMap.find e Gamma = Some m -> FloverMap.find e Gamma2 = Some m) -> (forall e m, FloverMap.find e Gamma = Some m ->
FloverMap.find e Gamma2 = Some m) ->
eval_expr E (toRExpMap Gamma2) (toRExp e) v m -> eval_expr E (toRExpMap Gamma2) (toRExp e) v m ->
m = mG). m = mG).
...@@ -123,12 +128,6 @@ Ltac validTypes_simp := ...@@ -123,12 +128,6 @@ Ltac validTypes_simp :=
Open Scope string_scope. Open Scope string_scope.
Definition getTypeMap (r:result (FloverMap.t mType)) :FloverMap.t mType:=
match r with
|Succes m => m
| _ => FloverMap.empty mType
end.
Definition isMonotone mOldO mNew := Definition isMonotone mOldO mNew :=
match mOldO with match mOldO with
|None => true |None => true
...@@ -165,21 +164,21 @@ Fixpoint getValidMap (Gamma:FloverMap.t mType) (e:expr Q) ...@@ -165,21 +164,21 @@ Fixpoint getValidMap (Gamma:FloverMap.t mType) (e:expr Q)
| Unop u e1 => | Unop u e1 =>
rlet akk_new := getValidMap Gamma e1 akk in rlet akk_new := getValidMap Gamma e1 akk in
match FloverMap.find e1 akk_new with match FloverMap.find e1 akk_new with
| None => Fail _ "Cannot Typecheck unary operator"
| Some m_e1 => | Some m_e1 =>
if (isFixedPointB m_e1) if (isFixedPointB m_e1)
then then
match mOldO with match mOldO with
|None => Fail _ "Undefined fixed-point type"
|Some mFix => |Some mFix =>
if (isCompat m_e1 mFix) if (isCompat m_e1 mFix)
then addMono e mFix akk_new then addMono e mFix akk_new
else Fail _ "Incompatible type assignment" else Fail _ "Incompatible type assignment"
|None => Fail _ "Undefined fixed-point type"
end end
else else
if (isMonotone mOldO m_e1) if (isMonotone mOldO m_e1)
then addMono e m_e1 akk_new then addMono e m_e1 akk_new
else Fail _ "Wrong type annotation for unary constant" else Fail _ "Wrong type annotation for unary constant"
| None => Fail _ "Cannot Typecheck unary operator"
end end
| Binop b e1 e2 => | Binop b e1 e2 =>
rlet akk1_map := getValidMap Gamma e1 akk in rlet akk1_map := getValidMap Gamma e1 akk in
...@@ -199,11 +198,11 @@ Fixpoint getValidMap (Gamma:FloverMap.t mType) (e:expr Q) ...@@ -199,11 +198,11 @@ Fixpoint getValidMap (Gamma:FloverMap.t mType) (e:expr Q)
end end
else else
match (join_fl t1 t2) with match (join_fl t1 t2) with
| None => Fail _ "Could not compute join for arguments"
| Some m => | Some m =>
if (isMonotone mOldO m) if (isMonotone mOldO m)
then addMono e m akk2_map then addMono e m akk2_map
else Fail _ "Wrong type annotation for binary operator" else Fail _ "Wrong type annotation for binary operator"
| None => Fail _ "Could not compute join for arguments"
end end
| _, _ => Fail _ "Could not compute type for arguments" | _, _ => Fail _ "Could not compute type for arguments"
end end
...@@ -239,20 +238,20 @@ Fixpoint getValidMap (Gamma:FloverMap.t mType) (e:expr Q) ...@@ -239,20 +238,20 @@ Fixpoint getValidMap (Gamma:FloverMap.t mType) (e:expr Q)
rlet akk_new := getValidMap Gamma e1 akk in rlet akk_new := getValidMap Gamma e1 akk in
let m1 := FloverMap.find e1 akk_new in let m1 := FloverMap.find e1 akk_new in
match m1 with match m1 with
| None => Fail _ "Could not find cast argument type"
| Some t1 => | Some t1 =>
if (isFixedPointB t1) if (isFixedPointB t1)
then then
match mOldO with match mOldO with
|None => Fail _ "Could not find fixed-point type for cast"
|Some mFix => if (mTypeEq m mFix && morePrecise t1 mFix) |Some mFix => if (mTypeEq m mFix && morePrecise t1 mFix)
then addMono e mFix akk_new then addMono e mFix akk_new
else Fail _ "Incorrect fixed-point type" else Fail _ "Incorrect fixed-point type"
|None => Fail _ "Could not find fixed-point type for cast"
end end
else else
if (morePrecise t1 m && isMonotone mOldO m) if (morePrecise t1 m && isMonotone mOldO m)
then addMono e m akk_new then addMono e m akk_new
else Fail _ "Cannot cast down to lower precision" else Fail _ "Cannot cast down to lower precision"
| None => Fail _ "Could not find case argument type"
end end
end. end.
...@@ -275,93 +274,6 @@ Proof. ...@@ -275,93 +274,6 @@ Proof.
eauto using tMap_def. eauto using tMap_def.
Qed. Qed.
Lemma no_cycle_unop e:
forall u, Q_orderedExps.exprCompare e (Unop u e) <> Eq.
induction e; intros *; cbn in *; try congruence.
destruct (unopEq u u0) eqn:?; try auto.
destruct (unopEq u Neg); congruence.
Qed.
Lemma no_cycle_cast e:
forall m, Q_orderedExps.exprCompare e (Downcast m e) <> Eq.
induction e; intros *; cbn in *; try congruence.
destruct (mTypeEq m m0) eqn:?; try auto.
destruct m; destruct m0; type_conv; try congruence;
cbn; hnf; intros; try congruence.
destruct (w ?= w0)%positive eqn:?; try congruence.
apply Pos.compare_eq in Heqc.
apply N.compare_eq in H; subst; congruence.
Qed.
Lemma no_cycle_binop_left e1:
forall b e2, Q_orderedExps.exprCompare e1 (Binop b e1 e2) <> Eq.