Merge with IEEE connection that has been proven in HOL4, as well as adding...

Merge with IEEE connection that has been proven in HOL4, as well as adding implementation of IEEE range validator in Coq and HOL4.

coq/CertificateChecker.v

@@ -6,7 +6,7 @@
 **)
 Require Import Coq.Reals.Reals Coq.QArith.Qreals.
 Require Import Daisy.Infra.RealSimps Daisy.Infra.RationalSimps Daisy.Infra.RealRationalProps Daisy.Infra.Ltacs.
-Require Import Daisy.IntervalValidation Daisy.ErrorValidation Daisy.Environments Daisy.Typing.
+Require Import Daisy.IntervalValidation Daisy.ErrorValidation Daisy.Environments Daisy.Typing Daisy.FPRangeValidator.
 
 Require Export Coq.QArith.QArith.
 Require Export Daisy.Infra.ExpressionAbbrevs Daisy.Commands.
@@ -14,7 +14,7 @@ Require Export Daisy.Infra.ExpressionAbbrevs Daisy.Commands.
 (** Certificate checking function **)
 Definition CertificateChecker (e:exp Q) (absenv:analysisResult) (P:precond) (defVars:nat -> option mType) :=
   if (typeCheck e defVars (typeMap defVars e)) then
-    if (validIntervalbounds e absenv P NatSet.empty)
+    if (validIntervalbounds e absenv P NatSet.empty) && FPRangeValidator e absenv (typeMap defVars e) NatSet.empty
     then (validErrorbound e (typeMap defVars e) absenv NatSet.empty)
     else false
   else false.
@@ -63,19 +63,21 @@ Proof.
   assert (NatSet.Subset (usedVars e -- NatSet.empty) (Expressions.usedVars e)).
   { hnf; intros a in_empty.
     set_tac. }
-  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).
+  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).
   { intros v v_in_empty.
     rewrite NatSet.mem_spec in v_in_empty.
     inversion v_in_empty. }
   edestruct validIntervalbounds_sound as [vR [eval_real real_bounds_e]]; eauto.
-  destruct (validErrorbound_sound e P (typeMap defVars e) L approxE1E2 H0 eval_real R0 L0 H1 P_valid H absenv_eq) as [[vF [mF eval_float]] err_bounded]; 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.
 
 Definition CertificateCheckerCmd (f:cmd Q) (absenv:analysisResult) (P:precond) defVars:=
   if (typeCheckCmd f defVars (typeMapCmd defVars f) && validSSA f (freeVars f))
   then
-    if (validIntervalboundsCmd f absenv P NatSet.empty)
+    if (validIntervalboundsCmd f absenv P NatSet.empty) &&
+       FPRangeValidatorCmd f absenv (typeMapCmd defVars f) NatSet.empty
     then (validErrorboundCmd f (typeMapCmd defVars f) absenv NatSet.empty)
     else false
   else false.
@@ -114,6 +116,7 @@ Proof.
   { eapply ssa_equal_set; try eauto.
     apply NatSetProps.empty_union_2.
     apply NatSet.empty_spec. }
+  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) as no_dVars_valid.

coq/ErrorValidation.v

@@ -2256,13 +2256,14 @@ Proof.
     + rename R into valid_rec.
       rewrite (typingSoundnessExp _ _  L0 eval_float_e) in *;
         simpl in *.
+      destruct (Gamma (Var Q n)) eqn:?; try congruence.
       match goal with
       | [ H: _ && _ = true |- _] => andb_to_prop H
       end.
       type_conv.
       destruct (IHf absenv (updEnv n v E1) (updEnv n vF E2) outVars fVars
                     (NatSet.add n dVars) vR elo ehi err P Gamma
-                    (updDefVars n m defVars))
+                    (updDefVars n m0 defVars))
         as [vF_res [m_res step_res]];
         eauto.
       { eapply ssa_equal_set; eauto.
@@ -2381,13 +2382,14 @@ Proof.
     rename R into valid_rec.
     rewrite (typingSoundnessExp _ _  L0 eval_float_e) in *;
       simpl in *.
+    destruct (Gamma (Var Q n)); try congruence.
     match goal with
     | [ H: _ && _ = true |- _] => andb_to_prop H
     end.
     type_conv.
     apply (IHf absenv (updEnv n v E1) (updEnv n v0 E2) outVars fVars
                (NatSet.add n dVars) vR vF mF elo ehi err P Gamma
-               (updDefVars n m defVars));
+               (updDefVars n m0 defVars));
       eauto.
     + eapply approxUpdBound; try auto.
       simpl in *.

coq/FPRangeValidator.v

+
+(* TODO: Flocq ops open machine_ieeeTheory binary_ieeeTheory lift_ieeeTheory realTheory *)
+
+Require Import Coq.QArith.QArith Coq.QArith.Qreals Coq.Reals.Reals Coq.micromega.Psatz.
+
+Require Import Daisy.Infra.MachineType Daisy.Typing Daisy.Infra.RealSimps Daisy.IntervalValidation Daisy.ErrorValidation Daisy.Commands Daisy.Environments Daisy.ssaPrgs Daisy.Infra.Ltacs Daisy.Infra.RealRationalProps.
+
+Fixpoint FPRangeValidator (e:exp Q) (A:analysisResult) typeMap dVars {struct e} : bool :=
+  match typeMap e with
+  |Some m =>
+        let (iv_e, err_e) := A e in
+        let iv_e_float := widenIntv iv_e err_e in
+        let recRes :=
+            match e with
+            | Binop b e1 e2 =>
+              FPRangeValidator e1 A typeMap dVars &&
+              FPRangeValidator e2 A typeMap dVars
+            | Unop u e =>
+              FPRangeValidator e A typeMap dVars
+            | Downcast m e => FPRangeValidator e A typeMap dVars
+            | _ =>  true
+            end
+        in
+        match e with
+        | Var _ v =>
+          if NatSet.mem v dVars
+          then true
+          else
+            if (validValue (ivhi iv_e_float) m &&
+                validValue (ivlo iv_e_float) m)
+            then ((normal (ivlo iv_e_float) m) || (Qeq_bool (ivlo iv_e_float) 0)) &&
+                  (normal (ivhi iv_e_float) m || (Qeq_bool (ivhi iv_e_float) 0)) && recRes
+            else
+              false
+        | _ => if (validValue (ivhi iv_e_float) m &&
+                validValue (ivlo iv_e_float) m)
+              then ((normal (ivlo iv_e_float) m) || (Qeq_bool (ivlo iv_e_float) 0)) &&
+                  (normal (ivhi iv_e_float) m || (Qeq_bool (ivhi iv_e_float) 0)) && recRes
+              else
+                false
+        end
+  | None => false
+  end.
+
+Fixpoint FPRangeValidatorCmd (f:cmd Q) (A:analysisResult) typeMap dVars :=
+  match f with
+  | Let m n e g =>
+    if FPRangeValidator e A typeMap dVars
+    then FPRangeValidatorCmd g A typeMap (NatSet.add n dVars)
+     else false
+| Ret e => FPRangeValidator e A typeMap dVars
+  end.
+
+Ltac prove_fprangeval m v L1 R:=
+  destruct m eqn:?; try auto;
+  unfold normal, Normal, validValue, Denormal in *; canonize_hyps;
+  rewrite orb_true_iff in *;
+  destruct L1; destruct R; canonize_hyps;
+  rewrite <- Rabs_eq_Qabs in *;
+  Q2R_to_head;
+  rewrite <- Q2R_minus, <- Q2R_plus in *;
+  repeat (match goal with
+          |H: _ = true |- _ => andb_to_prop H
+          end);
+  destruct (Req_dec v 0); try auto;
+  destruct (Rle_lt_dec (Rabs v) (Q2R (minValue m)))%R (* denormal case *);
+  try auto;
+  destruct (Rle_lt_dec (Rabs v) (Q2R (maxValue m)))%R; lra.
+
+
+Theorem FPRangeValidator_sound:
+  forall (e:exp Q) E1 E2 Gamma v m A tMap P fVars dVars,
+  approxEnv E1 Gamma A fVars dVars E2 ->
+  eval_exp E2 Gamma (toRExp e) v m ->
+  typeCheck e Gamma tMap = true ->
+  validIntervalbounds e A P dVars = true ->
+  validErrorbound e tMap A dVars = true ->
+  FPRangeValidator e A tMap dVars = true ->
+  NatSet.Subset (NatSet.diff (usedVars e) dVars) fVars ->
+  (forall v, NatSet.In v fVars ->
+        exists vR, E1 v = Some vR /\ Q2R (fst (P v)) <= vR <= Q2R (snd (P v)))%R ->
+  (forall v, NatSet.In v fVars \/ NatSet.In v dVars ->
+        exists m, Gamma v = Some m) ->
+  (forall v, NatSet.In v dVars ->
+        exists vR, E1 v = Some vR /\
+              Q2R (fst (fst (A (Var Q v)))) <= vR <= Q2R (snd (fst (A (Var Q v)))))%R ->
+  (forall v, NatSet.In v dVars ->
+        exists vF m, E2 v = Some vF /\ tMap (Var Q v) = Some m /\ validFloatValue vF m) ->
+  validFloatValue v m.
+Proof.
+  intros *.
+  unfold FPRangeValidator.
+  intros.
+  destruct (A e) as [iv_e err_e] eqn:?;
+    destruct iv_e as [e_lo e_hi] eqn:?; simpl in *.
+  assert (tMap e = Some m)
+    as type_e
+      by (eapply typingSoundnessExp; eauto).
+  subst; simpl in *.
+  unfold validFloatValue.
+  assert (exists vR, eval_exp E1 (toRMap Gamma) (toREval (toRExp e)) vR M0 /\
+                Q2R (fst (fst (A e))) <= vR <= Q2R (snd (fst (A e))))%R
+         as eval_real_exists.
+  { eapply validIntervalbounds_sound; eauto.
+    - intros; apply H8.
+      rewrite <- NatSet.mem_spec; auto.
+    - intros. apply H6.
+      rewrite <- NatSet.mem_spec; auto.
+    - intros. apply H7.
+      set_tac.
+      rewrite <- NatSet.union_spec; auto. }
+  destruct eval_real_exists as [vR [eval_real vR_bounded]].
+  assert (Rabs (vR - v) <= Q2R (snd (A e)))%R.
+  { eapply validErrorbound_sound; eauto.
+    - intros * v1_dVar.
+      apply H8; set_tac.
+    - intros * v0_fVar.
+      apply H6. rewrite <- NatSet.mem_spec; auto.
+    - intros * v1_in_union.
+      apply H7; set_tac.
+      rewrite NatSet.union_spec in v1_in_union; auto.
+    - eauto ; instantiate (1:= e_hi).
+      instantiate (1:=e_lo). rewrite Heqp. reflexivity. }
+  rewrite Heqp in *; simpl in *.
+  destruct (distance_gives_iv (a:=vR) v (e:=Q2R err_e) (Q2R e_lo, Q2R e_hi))
+    as [v_in_errIv];
+    try auto.
+  unfold IVlo, IVhi in *; simpl in *.
+  assert (Rabs v <= Rabs (Q2R e_hi + Q2R err_e) \/
+          Rabs v <= Rabs (Q2R e_lo - Q2R err_e))%R
+    as abs_bounded
+    by (apply bounded_inAbs; auto).
+  destruct e;
+    unfold validFloatValue in *; simpl in *;
+      rewrite type_e, Heqp in *; simpl in *.
+  - destruct (n mem dVars) eqn:?; simpl in *.
+    + destruct (H9 n); try set_tac.
+      destruct H12 as [m2 [env_eq [map_eq validVal]]].
+      inversion H0; subst.
+      rewrite env_eq in H14; inversion H14; subst.
+      rewrite map_eq in type_e; inversion type_e; subst; auto.
+    + andb_to_prop H4.
+      prove_fprangeval m v L1 R.
+  - andb_to_prop H4.
+    prove_fprangeval m v L1 R.
+  - andb_to_prop H4.
+    prove_fprangeval m v L1 R.
+  - andb_to_prop H4.
+    prove_fprangeval m v L1 R.
+  - andb_to_prop H4.
+    prove_fprangeval m v L1 R.
+Qed.
+
+Lemma FPRangeValidatorCmd_sound (f:cmd Q):
+  forall E1 E2 Gamma v vR m A tMap P fVars dVars outVars,
+  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 ->
+  validIntervalboundsCmd f A P dVars = true ->
+  validErrorboundCmd f tMap A dVars = true ->
+  FPRangeValidatorCmd f A tMap dVars = true ->
+  NatSet.Subset (NatSet.diff (freeVars f) dVars) fVars ->
+  (forall v,
+      NatSet.In v fVars ->
+      exists vR, E1 v = Some vR /\ Q2R (fst (P v)) <= vR <= Q2R (snd (P v)))%R ->
+  (forall v,
+      NatSet.In v fVars \/ NatSet.In v dVars ->
+      exists m, Gamma v = Some m) ->
+  (forall v,
+      NatSet.In v dVars ->
+      exists vR,
+        E1 v = Some vR /\ Q2R (ivlo (fst (A (Var Q v)))) <= vR /\
+        vR <= Q2R (ivhi(fst (A (Var Q v)))))%R ->
+  (forall v,
+      NatSet.In v dVars ->
+      exists vF m,
+        E2 v = Some vF /\ tMap (Var Q v) = 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 *));
+      repeat match goal with
+             | H : _ = true |- _ => andb_to_prop H
+             end.
+      - assert (tMap e = Some m)
+          by(eapply typingSoundnessExp; eauto).
+        match_pat (ssa _ _ _) (fun H => inversion H; subst; simpl in *).
+        destruct (A e) as [iv_e err_e] eqn:?;
+          destruct iv_e as [e_lo e_hi] eqn:?.
+        edestruct (validErrorbound_sound e (E1:=E1) (E2:=E2) (fVars:=fVars) (dVars := dVars) P (absenv:=A) (nR:=v0) (err:=err_e)) as [[vF_e [m_e eval_float_e]] err_bounded_e]; eauto.
+        + set_tac. split; try auto.
+          rewrite NatSet.remove_spec, NatSet.union_spec; split; try auto.
+          hnf; intros; subst.
+          set_tac.
+        + intros. apply H10; auto; set_tac.
+        + intros; apply H8; auto. rewrite <- NatSet.mem_spec; auto.
+        + intros. apply H9; set_tac. rewrite <- NatSet.union_spec; auto.
+        + edestruct (validIntervalbounds_sound e A P (fVars:=fVars) (dVars:=dVars) E1); eauto.
+          * intros. apply H10; auto; set_tac.
+          * set_tac. split; try auto.
+            rewrite NatSet.remove_spec, NatSet.union_spec; split; try auto.
+            hnf; intros; subst.
+            set_tac.
+          * intros. apply H8. rewrite NatSet.mem_spec in *; auto.
+          * intros. instantiate (1:= Gamma); apply H9. set_tac.
+            rewrite NatSet.union_spec in *; auto.
+          * rewrite H3 in *.
+            destruct (tMap (Var Q n)) eqn:?; simpl in *; try congruence.
+            rename x into vR_e.
+            destruct H4 as [eval_e_real bounded_vR_e].
+            rewrite <- (meps_0_deterministic (toRExp e) eval_e_real H20) in *; try auto.
+            andb_to_prop R5.
+            apply (IHf (updEnv n vR_e E1) (updEnv n v1 E2)
+                          (updDefVars n m Gamma) v vR m0 A tMap P fVars
+                          (NatSet.add n dVars) (outVars)); eauto.
+            { apply approxUpdBound; auto.
+              simpl in *.
+              apply Rle_trans with (r2:= Q2R err_e); try lra.
+              rewrite Heqp in *; simpl in *.
+              eapply err_bounded_e. eauto.
+              apply Qle_Rle.
+              rewrite Qeq_bool_iff in *.
+              rewrite R1. lra. }
+            { eapply ssa_equal_set; eauto.
+              hnf. intros a; split; intros in_set.
+              - rewrite NatSet.add_spec, NatSet.union_spec;
+                  rewrite NatSet.union_spec, NatSet.add_spec in in_set.
+                destruct in_set as [P1 | [ P2 | P3]]; auto.
+              - rewrite NatSet.add_spec, NatSet.union_spec in in_set;
+                  rewrite NatSet.union_spec, NatSet.add_spec.
+                destruct in_set as [P1 | [ P2 | P3]]; auto. }
+            { eapply (swap_Gamma_bstep (Gamma1 := updDefVars n M0 (toRMap Gamma))); eauto.
+              eauto using Rmap_updVars_comm. }
+            { set_tac; split.
+              - rewrite NatSet.remove_spec, NatSet.union_spec.
+                split; try auto.
+                hnf; intros; subst.
+                apply H5; rewrite NatSet.add_spec; auto.
+              - hnf; intros.
+                apply H5; rewrite NatSet.add_spec; auto. }
+            { intros v2 v2_fVar.
+              unfold updEnv.
+              case_eq (v2 =? n); intros v2_eq.
+              - apply Nat.eqb_eq in v2_eq; subst.
+                set_tac.
+                exfalso; apply H16; set_tac.
+              - apply H8; auto. }
+            { intros. unfold updDefVars.
+              destruct (v2 =? n) eqn:?; eauto.
+              apply H9. destruct H4; try auto.
+              rewrite NatSet.add_spec in H4.
+              rewrite Nat.eqb_neq in *.
+              destruct H4; subst; try congruence; auto. }
+            { intros. unfold updEnv.
+              destruct (v2 =? n) eqn:?.
+              - exists vR_e. rewrite Nat.eqb_eq in *; subst.
+                split; try auto.
+                destruct bounded_vR_e;
+                  rewrite Heqp in *; simpl in *.
+                  split.
+                + apply Rle_trans with (r2:=Q2R e_lo); try lra.
+                  apply Qle_Rle. rewrite Qeq_bool_iff in *; rewrite R4; lra.
+                + apply Rle_trans with (r2:=Q2R e_hi); try lra.
+                  apply Qle_Rle; rewrite Qeq_bool_iff in *; rewrite R3; lra.
+              - apply H10. rewrite Nat.eqb_neq in *.
+                rewrite NatSet.add_spec in H4.
+                destruct H4; try auto; subst; congruence. }
+            { intros. unfold updEnv.
+              type_conv; subst.
+              destruct (v2 =? n) eqn:?; try rewrite Nat.eqb_eq in *;
+                try rewrite Nat.eqb_neq in *.
+              - exists v1; subst. exists m1; repeat split; try auto.
+                eapply FPRangeValidator_sound; eauto.
+                set_tac. split; try auto.
+                rewrite NatSet.remove_spec, NatSet.union_spec.
+                split; try auto.
+                hnf; intros; subst; set_tac.
+              - apply H11.
+                rewrite NatSet.add_spec in H4; destruct H4;
+                  auto; subst; congruence. }
+  - eapply FPRangeValidator_sound; eauto.
+Qed.
\ No newline at end of file

coq/IEEE_connection.v

-Require Import Coq.Reals.Reals Coq.QArith.QArith Coq.micromega.Psatz
+Require Import Coq.Reals.Reals Coq.QArith.QArith Coq.QArith.Qabs Coq.micromega.Psatz
         Coq.QArith.Qreals.
 Require Import Daisy.Expressions Daisy.Infra.RationalSimps
         Daisy.Infra.RealRationalProps.
 Require Import Flocq.Appli.Fappli_IEEE_bits Flocq.Appli.Fappli_IEEE
         Flocq.Core.Fcore_Raux Flocq.Prop.Fprop_relative.
 
-Definition valid_div a b (f:binary_float a b):=
-  match f with
-  |B754_finite _ _ _ _ _ _ => true
-  |_ => false
+Fixpoint eval_exp_float (e:exp (binary_float 53 1024)) (E:nat -> option (binary_float 53 1024)):=
+  match e with
+  | Var _ x => E x
+  | Const m v => Some v
+  | Unop Neg e =>
+    match eval_exp_float e E with
+    |Some v1 => Some (b64_opp v1)
+    |_ => None
+    end
+  | Unop Inv e => None
+  | Binop b e1 e2 =>
+    match eval_exp_float e1 E, eval_exp_float e2 E with
+    | Some f1, Some f2 =>
+      match b with
+      | Plus => Some (b64_plus mode_NE f1 f2)
+      | Sub => Some (b64_minus mode_NE f1 f2)
+      | Mult => Some (b64_mult mode_NE f1 f2)
+      | Div => Some (b64_div mode_NE f1 f2)
+      end
+    |_ , _ => None
+    end
+  | _ => None
   end.
 
-(* Fixpoint eval_exp_float (e:exp (binary_float 53 1024)) (E:nat -> option (binary_float 53 1024)):= *)
-(*   match e with *)
-(*   |Const c => if (is_finite 53 1024 c) then Some c else None *)
-(*   |Var _ x => E x *)
-(*   |Binop b e1 e2 => *)
-(*    match eval_exp_float e1 E, eval_exp_float e2 E with *)
-(*    |Some f1, Some f2 => *)
-(*     if (is_finite 53 1024 f1 && is_finite 53 1024 f2) *)
-(*     then *)
-(*       match b with *)
-(*       |Plus => Some (b64_plus mode_NE f1 f2) *)
-(*       |Sub => Some (b64_minus mode_NE f1 f2) *)
-(*       |Mult => Some (b64_mult mode_NE f1 f2) *)
-(*       |Div => if (valid_div f2) then Some (b64_div mode_NE f1 f2) else None *)
-(*       end *)
-(*     else *)
-(*       None *)
-(*      |_ , _ => None *)
-(*    end *)
-(*    | _ => None *)
-(*   end. *)
+Definition optionLift (A B:Type) (e:option A) (some_cont:A -> B) (none_cont:B) :=
+  match e with
+  | Some v => some_cont v
+  | None => none_cont
+  end.
+
+Definition normal_or_zero v :=
+  Qeq_bool v 0 || Qle_bool (minValue M64) (Qabs v).
 
 (* Lemma eval_exp_float_finite e E: *)
 (*   forall v, eval_exp_float e E = Some v -> *)

coq/Infra/Ltacs.v

@@ -32,6 +32,18 @@ Ltac canonize_Q_to_R :=
 
 Ltac canonize_hyps := repeat canonize_Q_prop; repeat canonize_Q_to_R.
 
+Ltac Q2R_to_head_step :=
+  match goal with
+  | [ H: context[Q2R ?a + Q2R ?b] |- _] => rewrite <- Q2R_plus in H
+  | [ H: context[Q2R ?a - Q2R ?b] |- _] => rewrite <- Q2R_minus in H
+  | [ H: context[Q2R ?a * Q2R ?b] |- _] => rewrite <- Q2R_minus in H
+  | [ |- context[Q2R ?a + Q2R ?b]] => rewrite <- Q2R_plus
+  | [ |- context[Q2R ?a - Q2R ?b]] => rewrite <- Q2R_minus
+  | [ |- context[Q2R ?a * Q2R ?b]] => rewrite <- Q2R_minus
+  end.
+
+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;
@@ -66,4 +78,13 @@ Ltac destruct_if :=
     intros name;
     rewrite name in *;
     try congruence
-  end .
\ No newline at end of file
+  end.
+
+(* HOL4 Style patter matching tactics *)
+Tactic Notation "lift " tactic(t) :=
+  fun H => t H.
+
+Tactic Notation "match_pat" open_constr(pat) tactic(t) :=
+  match goal with
+  | [H: ?ty |- _ ] => unify pat ty; t H
+  end.
\ No newline at end of file

coq/Infra/MachineType.v

@@ -11,7 +11,7 @@ Require Import Daisy.Infra.RealRationalProps.
 (**
    Define machine precision as datatype
  **)
-Inductive mType: Type := M0 | M32 | M64 | M128 | M256.
+Inductive mType: Type := M0 | M16 | M32 | M64. (*| M128 | M256*)
 
 (**
   Injection of machine types into Q
@@ -19,12 +19,14 @@ Inductive mType: Type := M0 | M32 | M64 | M128 | M256.
 Definition mTypeToQ (e:mType) :Q :=
   match e with
   | M0 => 0
+  | M16 => (Qpower (2#1) (Zneg 11))
   | M32 => (Qpower (2#1) (Zneg 24))
   | M64 => (Qpower (2#1) (Zneg 53))
+  (*
   (* 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))
+  | M256 => (Qpower (2#1) (Zneg 211)) *)
   end.
 
 Arguments mTypeToQ _/.
@@ -49,10 +51,11 @@ Qed.
 Definition mTypeEq (m1:mType) (m2:mType) :=
   match m1, m2 with
   | M0, M0 => true
+  | M16, M16 => true
   | M32, M32 => true
   | M64, M64 => true
-  | M128, M128 => true
-  | M256, M256 => true
+  (* | M128, M128 => true *)
+  (* | M256, M256 => true *)
   | _, _ => false
   end.
 
@@ -141,4 +144,67 @@ Definition join (m1:mType) (m2:mType) :=
 (*   unfold join. *)
 (*   intros. *)
 (*   destruct m1, m2; simpl in *; cbv in *; try congruence; try auto. *)
-(* Qed. *)
\ No newline at end of file
+(* Qed. *)
+
+Definition maxExponent (m:mType) :Z :=
+  match m with
+  | M0 => 0
+  | M16 => 15
+  | M32 => 127
+  | M64 => 1023
+  end.
+
+Definition minExponentPos (m:mType) :Z :=
+  match m with
+  | M0 => 0
+  | M16 => 14
+  | M32 => 126
+  | M64 => 1022
+  end.
+
+(**
+Goldberg - Handbook of Floating-Point Arithmetic: (p.183)
+(𝛃 - 𝛃^(1 - p)) * 𝛃^(e_max)
+
+which simplifies to 2^(e_max) for base 2
+**)
+Definition maxValue (m:mType) :=
+  Qpower (2#1) (maxExponent m).
+
+Definition minValue (m:mType) :=
+  Qinv (Qpower (2#1) (minExponentPos m)).
+
+(** Goldberg - Handbook of Floating-Point Arithmetic: (p.183)
+  𝛃^(e_min -p + 1) = 𝛃^(e_min -1) for base 2
+**)
+Definition minDenormalValue (m:mType) :=
+  Qinv (Qpower (2#1) (minExponentPos m - 1)).
+
+Definition normal (v:Q) (m:mType) :=
+  Qle_bool (minValue m) (Qabs v) && Qle_bool (Qabs v) (maxValue m).
+
+Definition denormal (v:Q) (m:mType) :=
+  Qle_bool (Qabs v) (minValue m) && negb (Qeq_bool v 0).
+
+Definition Normal (v:R) (m:mType) :=
+  (Q2R (minValue m) <= (Rabs v) /\ (Rabs v) <= Q2R (maxValue m))%R.
+
+Definition Denormal (v:R) (m:mType) :=
+  ((Rabs v) <= Q2R (minValue m) /\ ~ (v = 0))%R.
+(**
+  Predicate that is true if and only if the given value v is a valid
+  floating-point value according to the the type m.
+  Since we use the 1 + 𝝳 abstraction, the value must either be
+  in normal range or 0.
+**)
+Definition validFloatValue (v:R) (m:mType) :=
+  match m with
+  | M0 => True
+  | _ => Normal v m \/ Denormal v m \/ v = 0%R
+  end.
+
+Definition validValue (v:Q) (m:mType) :=
+  match m with
+  | M0 => true
+  | _ => Qle_bool (Qabs v) (maxValue m)
+  end.
\ No newline at end of file

coq/Infra/RealRationalProps.v

@@ -149,4 +149,13 @@ Lemma Rabs_0_equiv:
   (Rbasic_fun.Rabs 0 <= Q2R 0)%R.
 Proof.
   rewrite Q2R0_is_0, Rbasic_fun.Rabs_R0; lra.
+Qed.
+
+Lemma bounded_inAbs a b c:
+  (a <= b <= c -> (Rabs b <= Rabs c) \/ Rabs b <= Rabs a)%R.
+Proof.
+  intros.
+  unfold Rabs.
+  destruct (Rcase_abs b); destruct (Rcase_abs c); destruct (Rcase_abs a);
+    lra.
 Qed.
\ No newline at end of file

coq/Typing.v

@@ -101,9 +101,10 @@ Fixpoint typeCheckCmd (c:cmd Q) (Gamma:nat -> option mType) (tMap:exp Q -> optio