IntervalValidation.v 34.2 KB
Newer Older
Heiko Becker's avatar
Heiko Becker committed
1
(**
Heiko Becker's avatar
Heiko Becker committed
2 3 4 5 6
    Interval arithmetic checker and its soundness proof.
    The function validIntervalbounds checks wether the given analysis result is
    a valid range arithmetic for each sub term of the given expression e.
    The computation is done using our formalized interval arithmetic.
    The function is used in CertificateChecker.v to build the full checker.
Heiko Becker's avatar
Heiko Becker committed
7
**)
8
Require Import Coq.QArith.QArith Coq.QArith.Qreals QArith.Qminmax Coq.Lists.List Coq.micromega.Psatz.
9
Require Import Daisy.Infra.Abbrevs Daisy.Infra.RationalSimps Daisy.Infra.RealRationalProps.
10
Require Import Daisy.Infra.Ltacs Daisy.Infra.RealSimps Daisy.Typing.
11
Require Export Daisy.IntervalArithQ Daisy.IntervalArith Daisy.ssaPrgs.
12

13
Fixpoint validIntervalbounds (e:exp Q) (absenv:analysisResult) (P:precond) (validVars:NatSet.t) :=
14 15
  let (intv, _) := absenv e in
    match e with
16
    | Var _ _ v =>
17 18 19
      if NatSet.mem v validVars
      then true
      else isSupersetIntv (P v) intv && (Qleb (ivlo (P v)) (ivhi (P v)))
20
    | Const _ n => isSupersetIntv (n,n) intv
Heiko Becker's avatar
Heiko Becker committed
21
    | Unop o f =>
22 23 24
      if validIntervalbounds f absenv P validVars
      then
        let (iv, _) := absenv f in
Heiko Becker's avatar
Heiko Becker committed
25
        match o with
26
        | Neg =>
Heiko Becker's avatar
Heiko Becker committed
27
          let new_iv := negateIntv iv in
28 29
          isSupersetIntv new_iv intv
        | Inv =>
30 31 32 33 34 35
          if (((Qleb (ivhi iv) 0) && (negb (Qeq_bool (ivhi iv) 0))) ||
              ((Qleb 0 (ivlo iv)) && (negb (Qeq_bool (ivlo iv) 0))))
          then
            let new_iv := invertIntv iv in
            isSupersetIntv new_iv intv
          else false
Heiko Becker's avatar
Heiko Becker committed
36
        end
37
      else false
Heiko Becker's avatar
Heiko Becker committed
38
    | Binop op f1 f2 =>
39 40 41 42 43
      if ((validIntervalbounds f1 absenv P validVars) &&
          (validIntervalbounds f2 absenv P validVars))
      then
        let (iv1,_) := absenv f1 in
        let (iv2,_) := absenv f2 in
Heiko Becker's avatar
Heiko Becker committed
44
          match op with
45 46 47 48 49 50 51 52 53
          | Plus =>
            let new_iv := addIntv iv1 iv2 in
            isSupersetIntv new_iv intv
          | Sub =>
            let new_iv := subtractIntv iv1 iv2 in
            isSupersetIntv new_iv intv
          | Mult =>
            let new_iv := multIntv iv1 iv2 in
            isSupersetIntv new_iv intv
Heiko Becker's avatar
Heiko Becker committed
54
          | Div =>
55 56 57 58 59 60
            if (((Qleb (ivhi iv2) 0) && (negb (Qeq_bool (ivhi iv2) 0))) ||
                ((Qleb 0 (ivlo iv2)) && (negb (Qeq_bool (ivlo iv2) 0))))
            then
              let new_iv := divideIntv iv1 iv2 in
              isSupersetIntv new_iv intv
            else false
61
          end
62
      else false
63
    | Downcast _ f1 =>
64 65 66
      let (iv1, _) := absenv f1 in
      andb (validIntervalbounds f1 absenv P validVars) (andb (isSupersetIntv intv iv1) (isSupersetIntv iv1 intv))
           (* TODO: intv = iv1 might be a hard constraint... *)
67 68
    end.

69
Fixpoint validIntervalboundsCmd (f:cmd Q) (absenv:analysisResult) (P:precond) (validVars:NatSet.t) :bool:=
70
  match f with
71
  | Let m x e g =>
72
    if (validIntervalbounds e absenv P validVars &&
73 74
        Qeq_bool (fst (fst (absenv e))) (fst (fst (absenv (Var Q m x)))) &&
        Qeq_bool (snd (fst (absenv e))) (snd (fst (absenv (Var Q m x)))))
75 76
    then validIntervalboundsCmd g absenv P (NatSet.add x validVars)
    else false
77 78
  |Ret e =>
   validIntervalbounds e absenv P validVars
79 80
  end.

81 82 83 84 85 86 87 88
(* Fixpoint erasure (e:exp Q) :exp Q := *)
(*   match e with *)
(*   |Var _ m x => Var Q M0 x *)
(*   |Unop u e => Unop u (erasure e) *)
(*   |Binop b e1 e2 => Binop b (erasure e1) (erasure e2) *)
(*   |Downcast _ e => Downcast M0 (erasure e) *)
(*   |_ => e *)
(*   end. *)
89

90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165
(* Fixpoint erasureCmd (c:cmd Q) :cmd Q := *)
(*   match c with *)
(*   | Let m x e g => Let M0 x (erasure e) (erasureCmd g) *)
(*   | Ret e => Ret (erasure e) *)
(*   end. *)
Require Import Coq.MSets.MSets.

Lemma bla e m m0 v:
 typeExpression e (Var Q m0 v) = Some m ->
 NatSet.In v (usedVars e).
Proof.
  intros; induction e. 
  - simpl in *.
    case_eq (mTypeEqBool m1 m0 && (n =? v)); intros; auto; rewrite H0 in H.
    + andb_to_prop H0.
      apply InA_cons.
      left; symmetry.
      apply beq_nat_true; auto.
    + inversion H.
  - simpl in *; inversion H.
  - simpl in *; apply IHe; auto.
  - pose proof (detTypingBinop e1 e2 b).
    case_eq (typeExpression e1 (Var Q m0 v)); case_eq (typeExpression e2 (Var Q m0 v)); intros; auto.
    + specialize (H0 _ _ _ _ _ H H2 H1) as [H01 H02]; subst.
      simpl; apply NatSet.union_spec; left; apply IHe1; auto.
    + simpl.
      simpl in H; rewrite H1,H2 in H; inversion H; subst.
      apply NatSet.union_spec; left; apply IHe1; auto.
    + simpl; simpl in H.
      rewrite H1,H2 in H; inversion H; subst.
      apply NatSet.union_spec; right; apply IHe2; auto.
    + simpl in H; rewrite H1, H2 in H.
      inversion H.
  - apply IHe; auto.
Qed.    

(* Lemma bla2 e v: *)
(*  NatSet.In v (usedVars e) -> *)
(*  exists m0, typeExpression e (Var Q m0 v) = Some m0. *)
(* Proof. *)
(*   intros; induction e; simpl in *. *)
(*   - exists m. *)
(*     apply InA_singleton in H. *)
(*     rewrite H. *)
(*     rewrite <- beq_nat_refl, andb_true_r. *)
(*     assert (mTypeEqBool m m = true) by (apply EquivEqBoolEq; auto). *)
(*     rewrite H0; trivial. *)
(*   - inversion H. *)
(*   - apply IHe; auto. *)
(*   - apply NatSet.union_spec in H. *)
(*     destruct H. *)
(*     + pose proof (IHe1 H) as [m0 H0]; exists m0; rewrite H0; trivial. *)
(*     + pose proof (IHe2 H) as [m0 H0]; exists m0; rewrite H0; trivial. *)
(*       case_eq (typeExpression e1 (Var Q m0 v)); intros; auto. *)
(*       pose proof (bla e1 m0 v H1). *)
(*       pose proof (IHe1 H2) as [m1 H3]. *)
      
(*   - apply IHe; auto. *)
    
(* Lemma fvAreNotTyped v e m: *)
(*   ~ NatSet.In v (usedVars e) -> *)
(*   (typeExpression e) (Var Q m v) = None. *)
(* Proof. *)
(*   intros. *)
(*   induction e; simpl in *. *)
(*   Lemma stupid v n: *)
(*     ~ NatSet.In v (NatSet.singleton n) -> (n =? v) = false. *)
(*   Proof. *)
(*     intro. *)
(*   Admitted.     *)
(* Admitted. *)
(*   (*       assert (NatSet.In v (NatSet.singleton n) -> (n =? v) = true). *) *)
(* (*       intro. *) *)
(* (*       Require Import Coq.MSets.MSets. *) *)
(* (*       apply InA_cons in H0. *) *)
(* (*       destruct H0; auto. *) *)
166

167
Theorem ivbounds_approximatesPrecond_sound f absenv P V:
168 169 170 171
  validIntervalbounds f absenv P V = true ->
  forall v m, NatSet.In v (NatSet.diff (Expressions.usedVars f) V) ->
              (typeExpression f) (Var Q m v) = Some m ->
       Is_true(isSupersetIntv (P v) (fst (absenv (Var Q m v)))).
172
Proof.
Heiko Becker's avatar
Heiko Becker committed
173
  induction f; unfold validIntervalbounds.
174 175
  - simpl. intros approx_true v m0 v_in_fV typef; simpl in *.
    case_eq (mTypeEqBool m m0 && (n =? v)); intros; rewrite H in typef; inversion typef; subst.
176 177 178
    rewrite NatSet.diff_spec in v_in_fV.
    rewrite NatSet.singleton_spec in v_in_fV;
      destruct v_in_fV; subst.
179
    destruct (absenv (Var Q m0 n)); simpl in *.
180 181 182 183
    case_eq (NatSet.mem n V); intros case_mem;
      rewrite case_mem in approx_true; simpl in *.
    + rewrite NatSet.mem_spec in case_mem.
      contradiction.
184 185 186
    + apply Is_true_eq_left in approx_true.
      apply andb_prop_elim in approx_true.
      destruct approx_true; auto.
187 188 189 190
  - intros approx_true v0 m0 v_in_fV typef; simpl in *.
    inversion v_in_fV. 
  - intros approx_unary_true v m0 v_in_fV typef; simpl in *.  
    unfold typeExpression in typef; inversion typef.
Heiko Becker's avatar
Heiko Becker committed
191
    apply Is_true_eq_left in approx_unary_true.
192
    simpl in *.
193
    destruct (absenv (Unop u f)); destruct (absenv f); simpl in *.
Heiko Becker's avatar
Heiko Becker committed
194 195 196 197
    apply andb_prop_elim in approx_unary_true.
    destruct approx_unary_true.
    apply IHf; try auto.
    apply Is_true_eq_true; auto.
198
  - intros approx_bin_true v m0 v_in_fV typef.
199 200 201 202
    simpl in v_in_fV.
    rewrite NatSet.diff_spec in v_in_fV.
    destruct v_in_fV as [ v_in_fV v_not_in_V].
    rewrite NatSet.union_spec in v_in_fV.
203
    apply Is_true_eq_left in approx_bin_true.
204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224
    case_eq (typeExpression f1 (Var Q m0 v));
      case_eq (typeExpression f2 (Var Q m0 v)); intros; auto; subst.
    + pose proof (detTypingBinop f1 f2 b _ _ typef H0 H) as [H01 H02]; subst.
      destruct (absenv (Binop b f1 f2)); destruct (absenv f1);
        destruct (absenv f2); simpl in *.
      apply andb_prop_elim in approx_bin_true.
      destruct approx_bin_true.
      apply andb_prop_elim in H1.
      destruct H1.
      apply IHf1; auto.
      apply Is_true_eq_true; auto.
      rewrite NatSet.diff_spec; split; auto.
      eapply bla; eauto.
    + simpl in *; rewrite H0,H in typef; inversion typef; subst.
      destruct (absenv (Binop b f1 f2)); destruct (absenv f1);
        destruct (absenv f2); simpl in *.
      apply andb_prop_elim in approx_bin_true.
      destruct approx_bin_true.
      apply andb_prop_elim in H1.
      destruct H1.
      apply IHf1; auto.
225
      apply Is_true_eq_true; auto.
226
      rewrite NatSet.diff_spec; split; auto.
227 228 229 230 231 232 233 234 235
      eapply bla; eauto.
    + simpl in *; rewrite H0,H in typef; inversion typef; subst.
      destruct (absenv (Binop b f1 f2)); destruct (absenv f1);
        destruct (absenv f2); simpl in *.
      apply andb_prop_elim in approx_bin_true.
      destruct approx_bin_true.
      apply andb_prop_elim in H1.
      destruct H1.
      apply IHf2; auto.
236
      apply Is_true_eq_true; auto.
237
      rewrite NatSet.diff_spec; split; auto.
238 239 240 241
      eapply bla; eauto.
    + simpl in *; rewrite H0,H in typef; inversion typef; subst.
  - intros approx_rnd_true v m0 v_in_fV typef.
    simpl in *; destruct (absenv (Downcast m f)); destruct (absenv f).
242 243 244 245 246 247
    apply Is_true_eq_left in approx_rnd_true.
    apply andb_prop_elim in approx_rnd_true.
    destruct approx_rnd_true.
    apply IHf; auto.
    apply Is_true_eq_true in H; auto.
Qed.
248

Heiko Becker's avatar
Heiko Becker committed
249 250 251 252 253 254 255 256 257 258 259 260 261 262 263
Corollary Q2R_max4 a b c d:
  Q2R (IntervalArithQ.max4 a b c d) = max4 (Q2R a) (Q2R b) (Q2R c) (Q2R d).
Proof.
  unfold IntervalArithQ.max4, max4; repeat rewrite Q2R_max; auto.
Qed.

Corollary Q2R_min4 a b c d:
  Q2R (IntervalArithQ.min4 a b c d) = min4 (Q2R a) (Q2R b) (Q2R c) (Q2R d).
Proof.
  unfold IntervalArith.min4, min4; repeat rewrite Q2R_min; auto.
Qed.

Ltac env_assert absenv e name :=
  assert (exists iv err, absenv e = (iv,err)) as name by (destruct (absenv e); repeat eexists; auto).

264
Lemma validBoundsDiv_uneq_zero e1 e2 absenv P V ivlo_e2 ivhi_e2 err:
265
  absenv e2 = ((ivlo_e2,ivhi_e2), err) ->
266
  validIntervalbounds (Binop Div e1 e2) absenv P V = true ->
267 268 269 270 271 272 273
  (ivhi_e2 < 0) \/ (0 < ivlo_e2).
Proof.
  intros absenv_eq validBounds.
  unfold validIntervalbounds in validBounds.
  env_assert absenv (Binop Div e1 e2) abs_div; destruct abs_div as [iv_div [err_div abs_div]].
  env_assert absenv e1 abs_e1; destruct abs_e1 as [iv_e1 [err_e1 abs_e1]].
  rewrite abs_div, abs_e1, absenv_eq in validBounds.
274
  repeat (rewrite <- andb_lazy_alt in validBounds).
275 276 277
  apply Is_true_eq_left in validBounds.
  apply andb_prop_elim in validBounds.
  destruct validBounds as [_ validBounds]; apply andb_prop_elim in validBounds.
278
  destruct validBounds as [nodiv0 _].
279
  apply Is_true_eq_true in nodiv0.
280
  unfold isSupersetIntv in *; simpl in *.
281
  apply le_neq_bool_to_lt_prop; auto.
282 283
Qed.

284 285
Fixpoint getRetExp (V:Type) (f:cmd V) :=
  match f with
286
  |Let m x e g => getRetExp g
287 288 289
  | Ret e => e
  end.

290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340
(* Lemma blu1 (E:env) (absenv:analysisResult) (f1 f2: exp Q) dVars (b:binop): *)
(*   (forall (v : NatSet.elt) (m : mType), *)
(*       NatSet.mem v dVars = true -> *)
(*       typeExpression (Binop b f1 f2) (Var Q m v) = Some m -> *)
(*       exists vR : R, *)
(*         E v = Some (vR, m) /\ *)
(*         (Q2R (fst (fst (absenv (Var Q m v)))) <= vR <= Q2R (snd (fst (absenv (Var Q m v)))))%R) *)
(*   -> *)
(*   (forall (v : NatSet.elt) (m : mType), *)
(*       NatSet.mem v dVars = true -> *)
(*       typeExpression f1 (Var Q m v) = Some m -> *)
(*       exists vR : R, *)
(*         E v = Some (vR, m) /\ *)
(*         (Q2R (fst (fst (absenv (Var Q m v)))) <= vR <= Q2R (snd (fst (absenv (Var Q m v)))))%R). *)
(* Proof. *)
(*   intros. *)
(*   specialize (H v m H0). *)
(*   assert (typeExpression (Binop b f1 f2) (Var Q m v) = Some m). *)
(*   simpl; rewrite H1; auto. *)
  
  
(*   specialize (H H2). *)
(*   auto. *)
(* Qed. *)


(* Lemma blu2 (E:env) (absenv:analysisResult) (f1 f2: exp Q) dVars (b:binop): *)
(*   (forall (v : NatSet.elt) (m : mType), *)
(*       NatSet.mem v dVars = true -> *)
(*       typeExpression (Binop b f1 f2) (Var Q m v) = Some m -> *)
(*       exists vR : R, *)
(*         E v = Some (vR, m) /\ *)
(*         (Q2R (fst (fst (absenv (Var Q m v)))) <= vR <= Q2R (snd (fst (absenv (Var Q m v)))))%R) *)
(*   -> *)
(*   (forall (v : NatSet.elt) (m : mType), *)
(*       NatSet.mem v dVars = true -> *)
(*       typeExpression f2 (Var Q m v) = Some m -> *)
(*       exists vR : R, *)
(*         E v = Some (vR, m) /\ *)
(*         (Q2R (fst (fst (absenv (Var Q m v)))) <= vR <= Q2R (snd (fst (absenv (Var Q m v)))))%R). *)
(* Proof. *)
(*   intros. *)
(*   specialize (H v m H0). *)
(*   assert (typeExpression (Binop b f1 f2) (Var Q m v) = Some m). *)
(*   simpl; rewrite H1; auto. *)
(*   case_eq (typeExpression f1 (Var Q m v)); intros; auto. *)
(*   specialize (H H2). *)
(*   auto. *)
(* Qed. *)


341
Theorem validIntervalbounds_sound (f:exp Q) (absenv:analysisResult) (P:precond) fVars dVars (E:env):
Heiko Becker's avatar
Heiko Becker committed
342
  forall vR,
343 344 345 346 347
    validIntervalbounds f absenv P dVars = true ->
    (forall v m, NatSet.mem v dVars = true ->
                 (*(typeExpression f) (Var Q m v) = Some m ->*)
                 exists vR, E v = Some (vR, m) /\
                (Q2R (fst (fst (absenv (Var Q m v)))) <= vR <= Q2R (snd (fst (absenv (Var Q m v)))))%R) ->
Raphaël Monat's avatar
Raphaël Monat committed
348
    NatSet.Subset (NatSet.diff (Expressions.usedVars f) dVars) fVars ->
349
    (forall v, NatSet.mem v fVars = true ->
350
          exists vR, E v = Some (vR, M0) /\
351
                (Q2R (fst (P v)) <= vR <= Q2R (snd (P v)))%R) ->
352
    eval_exp E (toREval (toRExp f)) vR M0 ->
353
  (Q2R (fst (fst (absenv f))) <= vR <= Q2R (snd (fst (absenv f))))%R.
354
Proof.
Raphaël Monat's avatar
Raphaël Monat committed
355
  induction f; intros vR valid_bounds valid_definedVars usedVars_subset valid_usedVars eval_f.
356
  - unfold validIntervalbounds in valid_bounds.
357
    env_assert absenv (Var Q m n) absenv_var.
358
    destruct absenv_var as [ iv [err absenv_var]].
Raphaël Monat's avatar
Raphaël Monat committed
359
    specialize (valid_usedVars n).
360
    simpl; rewrite absenv_var in *; simpl in *.
361
    inversion eval_f; subst.
362
    case_eq (NatSet.mem n dVars); intros case_mem; rewrite case_mem in *; simpl in *.
363 364 365 366 367 368
    + specialize (valid_definedVars n m case_mem).
      assert (mTypeEqBool m m && (n =? n) = true).
      apply andb_true_iff; split; [ apply EquivEqBoolEq | rewrite <- beq_nat_refl ]; auto. 
      (* rewrite H in valid_definedVars. *)
      (* assert (Some m = Some m) by auto. *)
      (* specialize (valid_definedVars H0). *)
369
      destruct valid_definedVars as [vR' [E_n_eq precond_sound]].
370
      rewrite E_n_eq in *.
371
      inversion H2; subst.
372
      rewrite absenv_var in *; auto.
373 374 375
    + repeat (rewrite delta_0_deterministic in *; try auto).
      unfold isSupersetIntv in valid_bounds.
      andb_to_prop valid_bounds.
376 377 378 379
      apply Qle_bool_iff in L0;
        apply Qle_bool_iff in R0.
      apply Qle_Rle in L0;
        apply Qle_Rle in R0.
380
      simpl in *.
381 382 383 384
      assert (NatSet.mem n fVars = true) as in_fVars.
      * assert (NatSet.In n (NatSet.singleton n))
          as in_singleton by (rewrite NatSet.singleton_spec; auto).
        rewrite NatSet.mem_spec.
Raphaël Monat's avatar
Raphaël Monat committed
385 386
        hnf in usedVars_subset.
        apply usedVars_subset.
387
        rewrite NatSet.diff_spec, NatSet.singleton_spec.
388
        split; try auto.
389 390 391
        hnf; intros in_dVars.
        rewrite <- NatSet.mem_spec in in_dVars.
        rewrite in_dVars in case_mem; congruence.
Raphaël Monat's avatar
Raphaël Monat committed
392 393
      * specialize (valid_usedVars in_fVars);
          destruct valid_usedVars as [vR' [vR_def P_valid]].
394
        rewrite vR_def in H2; inversion H2; subst.
395
        lra.
396
  - unfold validIntervalbounds in valid_bounds.
397
    simpl in *;  destruct (absenv (Const m v)) as [intv err]; simpl in *.
398 399
    apply Is_true_eq_left in valid_bounds.
    apply andb_prop_elim in valid_bounds.
Heiko Becker's avatar
Heiko Becker committed
400
    destruct valid_bounds as [valid_lo valid_hi].
Heiko Becker's avatar
Heiko Becker committed
401
    inversion eval_f; subst.
402
    rewrite delta_0_deterministic; auto.
403 404
    unfold contained; simpl.
    split.
Heiko Becker's avatar
Heiko Becker committed
405
    + apply Is_true_eq_true in valid_lo.
406
      unfold Qleb in *.
Heiko Becker's avatar
Heiko Becker committed
407 408 409 410 411 412
      apply Qle_bool_iff in valid_lo.
      apply Qle_Rle in valid_lo; auto.
    + apply Is_true_eq_true in valid_hi.
      unfold Qleb in *.
      apply Qle_bool_iff in valid_hi.
      apply Qle_Rle in valid_hi; auto.
413 414
    + simpl in H2; rewrite Q2R0_is_0 in H2; auto.
  - case_eq (absenv (Unop u f)); intros intv err absenv_unop.
Heiko Becker's avatar
Heiko Becker committed
415 416
    destruct intv as [unop_lo unop_hi]; simpl.
    unfold validIntervalbounds in valid_bounds.
417
    simpl in valid_bounds; rewrite absenv_unop in valid_bounds.
418
    case_eq (absenv f); intros intv_f err_f absenv_f.
Heiko Becker's avatar
Heiko Becker committed
419 420 421 422 423 424
    rewrite absenv_f in valid_bounds.
    apply Is_true_eq_left in valid_bounds.
    apply andb_prop_elim in valid_bounds.
    destruct valid_bounds as [valid_rec valid_unop].
    apply Is_true_eq_true in valid_rec.
    inversion eval_f; subst.
425
    + specialize (IHf v1 valid_rec valid_definedVars usedVars_subset valid_usedVars H3).
Heiko Becker's avatar
Heiko Becker committed
426
      rewrite absenv_f in IHf; simpl in IHf.
427 428 429 430 431 432
      (* TODO: Make lemma *)
      unfold isSupersetIntv in valid_unop.
      apply andb_prop_elim in valid_unop.
      destruct valid_unop as [valid_lo valid_hi].
      apply Is_true_eq_true in valid_lo; apply Is_true_eq_true in valid_hi.
      apply Qle_bool_iff in valid_lo; apply Qle_bool_iff in valid_hi.
433
      pose proof (interval_negation_valid (iv :=(Q2R (fst intv_f),(Q2R (snd intv_f)))) (a :=v1)) as negation_valid.
434 435 436
      unfold contained, negateInterval in negation_valid; simpl in *.
      apply Qle_Rle in valid_lo; apply Qle_Rle in valid_hi.
      destruct IHf.
437
      split.
438
      * eapply Rle_trans. apply valid_lo.
439 440
        rewrite Q2R_opp; lra.
      * eapply Rle_trans.
441
        Focus 2. apply valid_hi.
442
        rewrite Q2R_opp; lra.
443
    + specialize (IHf v1 valid_rec valid_definedVars usedVars_subset valid_usedVars H4).
Heiko Becker's avatar
Heiko Becker committed
444
      rewrite absenv_f in IHf; simpl in IHf.
445
      apply andb_prop_elim in valid_unop.
446
      destruct valid_unop as [nodiv0 valid_unop].
447 448 449 450 451 452 453 454 455 456 457 458
      (* TODO: Make lemma *)
      unfold isSupersetIntv in valid_unop.
      apply andb_prop_elim in valid_unop.
      destruct valid_unop as [valid_lo valid_hi].
      apply Is_true_eq_true in valid_lo; apply Is_true_eq_true in valid_hi.
      apply Qle_bool_iff in valid_lo; apply Qle_bool_iff in valid_hi.
      assert ((Q2R (ivhi intv_f) < 0)%R \/ (0 < Q2R (ivlo intv_f))%R) as nodiv0_prop.
       * apply Is_true_eq_true in nodiv0.
         apply le_neq_bool_to_lt_prop in nodiv0.
         destruct nodiv0.
         { left; rewrite <- Q2R0_is_0; apply Qlt_Rlt; auto. }
         { right; rewrite <- Q2R0_is_0; apply Qlt_Rlt; auto. }
459
       * pose proof (interval_inversion_valid (iv :=(Q2R (fst intv_f),(Q2R (snd intv_f)))) (a :=v1)) as inv_valid.
460 461 462
         unfold contained, invertInterval in inv_valid; simpl in *.
         apply Qle_Rle in valid_lo; apply Qle_Rle in valid_hi.
         destruct IHf.
463
         rewrite delta_0_deterministic; auto.
464
         unfold perturb; split.
465
         { eapply Rle_trans. apply valid_lo.
466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486
           destruct nodiv0_prop as [nodiv0_neg | nodiv0_pos].
           (* TODO: Extract lemma maybe *)
           - assert (0 < - (Q2R (snd intv_f)))%R as negation_pos by lra.
             assert (- (Q2R (snd intv_f)) <= - v1)%R as negation_flipped_hi by lra.
             apply Rinv_le_contravar in negation_flipped_hi; try auto.
             rewrite <- Ropp_inv_permute in negation_flipped_hi; try lra.
             rewrite <- Ropp_inv_permute in negation_flipped_hi; try lra.
             apply Ropp_le_contravar in negation_flipped_hi.
             repeat rewrite Ropp_involutive in negation_flipped_hi;
               rewrite Q2R_inv; auto.
             hnf; intros is_0.
             rewrite <- Q2R0_is_0 in nodiv0_neg.
             apply Rlt_Qlt in nodiv0_neg; lra.
           - rewrite Q2R_inv.
             apply Rinv_le_contravar; try lra.
             hnf; intros is_0.
             assert (Q2R (fst intv_f) <= Q2R (snd intv_f))%R by lra.
             rewrite <- Q2R0_is_0 in nodiv0_pos.
             apply Rlt_Qlt in nodiv0_pos; apply Rle_Qle in H2; lra.
         }
         { eapply Rle_trans.
487
           Focus 2. apply valid_hi.
488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510
           destruct nodiv0_prop as [nodiv0_neg | nodiv0_pos].
           - assert (Q2R (fst intv_f) < 0)%R as fst_lt_0 by lra.
             assert (0 < - (Q2R (fst intv_f)))%R as negation_pos by lra.
             assert (- v1 <= - (Q2R (fst intv_f)))%R as negation_flipped_lo by lra.
             apply Rinv_le_contravar in negation_flipped_lo; try auto.
             rewrite <- Ropp_inv_permute in negation_flipped_lo; try lra.
             rewrite <- Ropp_inv_permute in negation_flipped_lo; try lra.
             apply Ropp_le_contravar in negation_flipped_lo.
             repeat rewrite Ropp_involutive in negation_flipped_lo;
               rewrite Q2R_inv; auto.
             hnf; intros is_0.
             rewrite <- Q2R0_is_0 in negation_pos.
             rewrite <- Q2R_opp in negation_pos.
             apply Rlt_Qlt in negation_pos; lra.
             assert (0 < - (Q2R (snd intv_f)))%R by lra.
             lra.
           - rewrite Q2R_inv.
             apply Rinv_le_contravar; try lra.
             hnf; intros is_0.
             assert (Q2R (fst intv_f) <= Q2R (snd intv_f))%R by lra.
             rewrite <- Q2R0_is_0 in nodiv0_pos.
             apply Rlt_Qlt in nodiv0_pos; apply Rle_Qle in H2; lra.
         }
511
         { rewrite Q2R0_is_0 in H1; auto. }
512
  - inversion eval_f; subst.
513 514
    rewrite delta_0_deterministic in eval_f; auto.
    rewrite delta_0_deterministic; auto.
Heiko Becker's avatar
Heiko Becker committed
515
    simpl in valid_bounds.
516 517 518
    case_eq (absenv (Binop b f1 f2)); intros iv err absenv_bin.
    case_eq (absenv f1); intros iv1 err1 absenv_f1.
    case_eq (absenv f2); intros iv2 err2 absenv_f2.
519
    simpl.
Heiko Becker's avatar
Heiko Becker committed
520
    rewrite absenv_bin, absenv_f1, absenv_f2 in valid_bounds.
Heiko Becker's avatar
Heiko Becker committed
521 522 523 524 525 526
    apply Is_true_eq_left in valid_bounds.
    apply andb_prop_elim in valid_bounds.
    destruct valid_bounds as [valid_rec valid_bin].
    apply andb_prop_elim in valid_rec.
    destruct valid_rec as [valid_e1 valid_e2].
    apply Is_true_eq_true in valid_e1; apply Is_true_eq_true in  valid_e2.
527
    specialize (IHf1 v1 valid_e1 valid_definedVars). 
528
      specialize (IHf2 v2 valid_e2 valid_definedVars).
Heiko Becker's avatar
Heiko Becker committed
529 530
    rewrite absenv_f1 in IHf1.
    rewrite absenv_f2 in IHf2.
531 532 533
    assert ((Q2R (fst (fst (iv1, err1))) <= v1 <= Q2R (snd (fst (iv1, err1))))%R) as valid_bounds_e1.
    + apply IHf1; try auto.
      intros v in_diff_e1.
Raphaël Monat's avatar
Raphaël Monat committed
534
      apply usedVars_subset.
535 536
      simpl. rewrite NatSet.diff_spec,NatSet.union_spec.
      rewrite NatSet.diff_spec in in_diff_e1.
Raphaël Monat's avatar
Raphaël Monat committed
537
      destruct in_diff_e1 as [ in_usedVars not_dVar].
538
      split; try auto.
539
      assert (m1 = M0) by (apply (ifM0isJoin_l M0 m1 m2); auto); subst; auto.
540 541 542
    + assert (Q2R (fst (fst (iv2, err2))) <= v2 <= Q2R (snd (fst (iv2, err2))))%R as valid_bounds_e2.
      * apply IHf2; try auto.
        intros v in_diff_e2.
Raphaël Monat's avatar
Raphaël Monat committed
543
        apply usedVars_subset.
544 545 546
        simpl. rewrite NatSet.diff_spec, NatSet.union_spec.
        rewrite NatSet.diff_spec in in_diff_e2.
        destruct in_diff_e2; split; auto.
547
        assert (m2 = M0) by (apply (ifM0isJoin_r M0 m1 m2); auto); subst; auto.
548 549 550 551 552 553 554 555 556 557 558 559
      * destruct b; simpl in *.
        { pose proof (interval_addition_valid (iv1 :=(Q2R (fst iv1),Q2R (snd iv1))) (iv2 :=(Q2R (fst iv2), Q2R (snd iv2)))) as valid_add.
          unfold validIntervalAdd in valid_add.
          specialize (valid_add v1 v2 valid_bounds_e1 valid_bounds_e2).
          unfold contained in valid_add.
          unfold isSupersetIntv in valid_bin.
          apply andb_prop_elim in valid_bin; destruct valid_bin as [valid_lo valid_hi].
          apply Is_true_eq_true in valid_lo; apply Is_true_eq_true in valid_hi.
          apply Qle_bool_iff in valid_lo; apply Qle_bool_iff in valid_hi.
          apply Qle_Rle in valid_lo; apply Qle_Rle in valid_hi.
          destruct valid_add as [valid_add_lo valid_add_hi].
          split.
560
          - eapply Rle_trans. (*rewrite absenv_bin;*) apply valid_lo.
561 562 563 564 565 566 567
            unfold ivlo. unfold addIntv.
            simpl in valid_add_lo.
            repeat rewrite <- Q2R_plus in valid_add_lo.
            rewrite <- Q2R_min4 in valid_add_lo.
            unfold absIvUpd; auto.
          - eapply Rle_trans.
            Focus 2.
568
            (*rewrite absenv_bin;*) apply valid_hi.
569 570 571 572 573 574 575 576 577 578 579 580 581 582 583
            unfold ivlo, addIntv.
            simpl in valid_add_hi.
            repeat rewrite <- Q2R_plus in valid_add_hi.
            rewrite <- Q2R_max4 in valid_add_hi.
            unfold absIvUpd; auto. }
        { pose proof (interval_subtraction_valid (iv1 := (Q2R (fst iv1),Q2R (snd iv1))) (iv2 :=(Q2R (fst iv2), Q2R (snd iv2)))) as valid_sub.
          specialize (valid_sub v1 v2 valid_bounds_e1 valid_bounds_e2).
          unfold contained in valid_sub.
          unfold isSupersetIntv in valid_bin.
          apply andb_prop_elim in valid_bin; destruct valid_bin as [valid_lo valid_hi].
          apply Is_true_eq_true in valid_lo; apply Is_true_eq_true in valid_hi.
          apply Qle_bool_iff in valid_lo; apply Qle_bool_iff in valid_hi.
          apply Qle_Rle in valid_lo; apply Qle_Rle in valid_hi.
          destruct valid_sub as [valid_sub_lo valid_sub_hi].
          split.
584
          - eapply Rle_trans. (*rewrite absenv_bin;*) apply valid_lo.
585 586 587 588 589 590 591 592
            unfold ivlo. unfold subtractIntv.
            simpl in valid_sub_lo.
            repeat rewrite <- Rsub_eq_Ropp_Rplus in valid_sub_lo.
            repeat rewrite <- Q2R_minus in valid_sub_lo.
            rewrite <- Q2R_min4 in valid_sub_lo.
            unfold absIvUpd; auto.
          - eapply Rle_trans.
            Focus 2.
593
            (*rewrite absenv_bin;*) apply valid_hi.
594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609
            unfold ivlo, addIntv.
            simpl in valid_sub_hi.
            repeat rewrite <- Rsub_eq_Ropp_Rplus in valid_sub_hi.
            repeat rewrite <- Q2R_minus in valid_sub_hi.
            rewrite <- Q2R_max4 in valid_sub_hi.
            unfold absIvUpd; auto. }
        { pose proof (interval_multiplication_valid (iv1 :=(Q2R (fst iv1),Q2R (snd iv1))) (iv2:=(Q2R (fst iv2), Q2R (snd iv2)))) as valid_mul.
          specialize (valid_mul v1 v2 valid_bounds_e1 valid_bounds_e2).
          unfold contained in valid_mul.
          unfold isSupersetIntv in valid_bin.
          apply andb_prop_elim in valid_bin; destruct valid_bin as [valid_lo valid_hi].
          apply Is_true_eq_true in valid_lo; apply Is_true_eq_true in valid_hi.
          apply Qle_bool_iff in valid_lo; apply Qle_bool_iff in valid_hi.
          apply Qle_Rle in valid_lo; apply Qle_Rle in valid_hi.
          destruct valid_mul as [valid_mul_lo valid_mul_hi].
          split.
610
          - eapply Rle_trans. (*rewrite absenv_bin;*) apply valid_lo.
611 612 613 614 615 616 617
            unfold ivlo. unfold multIntv.
            simpl in valid_mul_lo.
            repeat rewrite <- Q2R_mult in valid_mul_lo.
            rewrite <- Q2R_min4 in valid_mul_lo.
            unfold absIvUpd; auto.
          - eapply Rle_trans.
            Focus 2.
618
            (*rewrite absenv_bin;*) apply valid_hi.
619 620 621 622 623 624
            unfold ivlo, addIntv.
            simpl in valid_mul_hi.
            repeat rewrite <- Q2R_mult in valid_mul_hi.
            rewrite <- Q2R_max4 in valid_mul_hi.
            unfold absIvUpd; auto. }
        { pose proof (interval_division_valid (a:=v1) (b:=v2) (iv1:=(Q2R (fst iv1), Q2R (snd iv1))) (iv2:=(Q2R (fst iv2),Q2R (snd iv2)))) as valid_div.
625
          rewrite <- andb_lazy_alt in valid_bin.
626 627
          unfold contained in valid_div.
          unfold isSupersetIntv in valid_bin.
628 629
          apply andb_prop_elim in valid_bin; destruct valid_bin as [nodiv0 valid_bin].
          (** CONTINUE **)
630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661
          apply andb_prop_elim in valid_bin; destruct valid_bin as [valid_lo valid_hi].
          apply Is_true_eq_true in valid_lo; apply Is_true_eq_true in valid_hi.
          apply Qle_bool_iff in valid_lo; apply Qle_bool_iff in valid_hi.
          apply Qle_Rle in valid_lo; apply Qle_Rle in valid_hi.
          apply orb_prop_elim in nodiv0.
          assert (snd iv2 < 0 \/ 0 < fst iv2).
          - destruct nodiv0 as [lt_0 | lt_0];
              apply andb_prop_elim in lt_0; destruct lt_0 as [le_0 neq_0];
                apply Is_true_eq_true in le_0; apply Is_true_eq_true in neq_0;
                  apply negb_true_iff in neq_0; apply Qeq_bool_neq in neq_0;
                    rewrite Qle_bool_iff in le_0;
                    rewrite Qle_lteq in le_0; destruct le_0 as [lt_0 | eq_0];
                      [ | exfalso; apply neq_0; auto | | exfalso; apply neq_0; symmetry; auto]; auto.
          - destruct valid_div as [valid_div_lo valid_div_hi]; simpl; try auto.
            + rewrite <- Q2R0_is_0.
              destruct H; [left | right]; apply Qlt_Rlt; auto.
            + unfold divideInterval, IVlo, IVhi in valid_div_lo, valid_div_hi.
              simpl in *.
              assert (Q2R (fst iv2) <= (Q2R (snd iv2)))%R by lra.
              assert (~ snd iv2 == 0).
              * destruct H; try lra.
                hnf; intros ivhi2_0.
                apply Rle_Qle in H0.
                rewrite ivhi2_0 in H0.
                lra.
              * assert (~ fst iv2 == 0).
                { destruct H; try lra.
                  hnf; intros ivlo2_0.
                  apply Rle_Qle in H0.
                  rewrite ivlo2_0 in H0.
                  lra. }
                { split.
662
                  - eapply Rle_trans. (*rewrite absenv_bin;*) apply valid_lo.
663 664 665 666 667 668 669 670
                    unfold ivlo. unfold multIntv.
                    simpl in valid_div_lo.
                    rewrite <- Q2R_inv in valid_div_lo; [ | auto].
                    rewrite <- Q2R_inv in valid_div_lo; [ | auto].
                    repeat rewrite <- Q2R_mult in valid_div_lo.
                    rewrite <- Q2R_min4 in valid_div_lo; auto.
                  - eapply Rle_trans.
                    Focus 2.
671
                    (*rewrite absenv_bin;*) apply valid_hi.
672 673 674 675 676
                    simpl in valid_div_hi.
                    rewrite <- Q2R_inv in valid_div_hi; [ | auto].
                    rewrite <- Q2R_inv in valid_div_hi; [ | auto].
                    repeat rewrite <- Q2R_mult in valid_div_hi.
                    rewrite <- Q2R_max4 in valid_div_hi; auto. } }
677 678 679
    + simpl in H3; rewrite Q2R0_is_0 in H3; auto.
    + simpl in H3; rewrite Q2R0_is_0 in H3; auto.
  - unfold validIntervalbounds in valid_bounds.
680 681
    (*simpl erasure in valid_bounds.*)
    simpl in *; destruct (absenv (Downcast m f)); destruct (absenv f); simpl in *.
682 683 684 685 686 687 688 689 690 691 692 693 694 695
    apply Is_true_eq_left in valid_bounds.
    apply andb_prop_elim in valid_bounds.
    destruct valid_bounds as [vI1 vI2].
    apply andb_prop_elim in vI2.
    destruct vI2 as [vI2 vI2']. 
    apply Is_true_eq_true in vI2.
    apply Is_true_eq_true in vI2'.
    assert (isEqIntv i i0) as Eq by (apply supIntvAntisym; auto).
    destruct Eq as [Eqlo Eqhi].
    simpl in *.
    apply Qeq_eqR in Eqlo; rewrite Eqlo.
    apply Qeq_eqR in Eqhi; rewrite Eqhi.
    apply IHf; auto.
    apply Is_true_eq_true in vI1; apply vI1.
696
Qed.
697 698

Theorem validIntervalboundsCmd_sound (f:cmd Q) (absenv:analysisResult):
699 700
  forall E vR fVars dVars outVars elo ehi err P,
    ssaPrg f (NatSet.union fVars dVars) outVars ->
701
    bstep (toREvalCmd (toRCmd f)) E vR M0  ->
702
    (forall v m, NatSet.mem v dVars = true ->
703
          exists vR,
704 705 706
            E v = Some (vR, m) /\
            (Q2R (fst (fst (absenv (Var Q m v)))) <= vR <= Q2R (snd (fst (absenv (Var Q m v)))))%R) ->
    (forall v m, NatSet.mem v fVars = true ->
707
          exists vR,
708
            E v = Some (vR, m) /\
709
            (Q2R (fst (P v)) <= vR <= Q2R (snd (P v)))%R) ->
710
    NatSet.Subset (NatSet.diff (Commands.freeVars f) dVars) fVars ->
711 712
    validIntervalboundsCmd f  absenv P dVars = true ->
    absenv (getRetExp f) = ((elo, ehi), err) ->
Heiko Becker's avatar
Heiko Becker committed
713
    (Q2R elo <=  vR <= Q2R ehi)%R.
714 715
Proof.
  induction f;
716
    intros *  ssa_f eval_f dVars_sound fVars_valid usedVars_subset valid_bounds_f absenv_f.
717 718 719 720
  - inversion ssa_f; subst.
    inversion eval_f; subst.
    unfold validIntervalboundsCmd in valid_bounds_f.
    andb_to_prop valid_bounds_f.
721
    inversion ssa_f; subst.
722
    specialize (IHf (updEnv n m v E) vR fVars (NatSet.add n dVars)).
723
    eapply IHf; eauto.
724 725 726 727 728 729 730 731 732 733
    + assert (NatSet.Equal (NatSet.add n (NatSet.union fVars dVars)) (NatSet.union fVars (NatSet.add n dVars))).
      * hnf. intros a; split; intros in_set.
        { 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. }
        { 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. }
      * eapply ssa_equal_set; eauto.
        symmetry; eauto.
734 735 736
    + 

      intros v0 m0 mem_v0. 
737 738 739 740 741 742 743 744 745 746 747 748
      unfold updEnv.
      case_eq (v0 =? n); intros v0_eq.
      * rename R1 into eq_lo;
          rename R0 into eq_hi.
        apply Qeq_bool_iff in eq_lo;
          apply Qeq_eqR in eq_lo.
        apply Qeq_bool_iff in eq_hi;
          apply Qeq_eqR in eq_hi.
        rewrite Nat.eqb_eq in v0_eq; subst.
        rewrite <- eq_lo, <- eq_hi.
        exists v; split; auto.
        eapply validIntervalbounds_sound; eauto.
Raphaël Monat's avatar
Raphaël Monat committed
749 750 751
        simpl in usedVars_subset.
        hnf. intros a in_usedVars.
        apply usedVars_subset.
752
        rewrite NatSet.diff_spec, NatSet.remove_spec, NatSet.union_spec.
Raphaël Monat's avatar
Raphaël Monat committed
753 754
        rewrite NatSet.diff_spec in in_usedVars.
        destruct in_usedVars as [ in_usedVars not_dVar].
755 756
        repeat split; try auto.
        { hnf; intros; subst.
757 758 759
          specialize (H5 n in_usedVars).
          rewrite <- NatSet.mem_spec in H5.
          rewrite H5 in H6; congruence. }
760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776
      * apply dVars_sound. rewrite NatSet.mem_spec.
        rewrite NatSet.mem_spec in mem_v0.
        rewrite NatSet.add_spec in mem_v0.
        destruct mem_v0; try auto.
        rewrite Nat.eqb_neq in v0_eq.
        exfalso; apply v0_eq; auto.
    + intros v0 mem_fVars.
      unfold updEnv.
      case_eq (v0 =? n); intros case_v0; auto.
      rewrite Nat.eqb_eq in case_v0; subst.
      assert (NatSet.mem n (NatSet.union fVars dVars) = true) as in_union.
      * rewrite NatSet.mem_spec, NatSet.union_spec; rewrite <- NatSet.mem_spec; auto.
      * rewrite in_union in *; congruence.
    + clear L R1 R0 R IHf.
      hnf. intros a a_freeVar.
      rewrite NatSet.diff_spec in a_freeVar.
      destruct a_freeVar as [a_freeVar a_no_dVar].
Raphaël Monat's avatar
Raphaël Monat committed
777
      apply usedVars_subset.
778 779 780 781 782 783 784 785 786
      simpl.
      rewrite NatSet.diff_spec, NatSet.remove_spec, NatSet.union_spec.
      repeat split; try auto.
      * hnf; intros; subst.
        apply a_no_dVar.
        rewrite NatSet.add_spec; auto.
      * hnf; intros a_dVar.
        apply a_no_dVar.
        rewrite NatSet.add_spec; auto.
787 788 789
  - unfold validIntervalboundsCmd in valid_bounds_f.
    inversion eval_f; subst.
    unfold updEnv.
790 791
    assert (Q2R (fst (fst (absenv (erasure e)))) <= vR <= Q2R (snd (fst (absenv (erasure e)))))%R.
    + simpl in valid_bounds_f; eapply validIntervalbounds_sound; eauto.
792
    + simpl in *. rewrite absenv_f in *; auto.
793
Qed.