IEEE_connection.v 51.3 KB
Newer Older
1
Require Import Coq.Reals.Reals Coq.QArith.QArith Coq.QArith.Qabs Coq.micromega.Psatz
2
        Coq.QArith.Qreals.
3
4
5
6
Require Import Flover.Expressions Flover.Infra.RationalSimps Flover.Typing
        Flover.IntervalValidation Flover.ErrorValidation Flover.CertificateChecker
        Flover.FPRangeValidator Flover.Environments Flover.Infra.RealRationalProps
        Flover.Commands Flover.Infra.Ltacs.
7
8
Require Import Flocq.Appli.Fappli_IEEE_bits Flocq.Appli.Fappli_IEEE
        Flocq.Core.Fcore_Raux Flocq.Prop.Fprop_relative.
9

Heiko Becker's avatar
Heiko Becker committed
10
11
12
13
Definition dmode := mode_NE.
Definition fl64:Type := binary_float 53 1024.

Definition normal_or_zero v :=
14
   (v = 0 \/ (Q2R (minValue_pos M64)) <= (Rabs v))%R.
Heiko Becker's avatar
Heiko Becker committed
15
16
17
18
19
20

Definition updFlEnv x v E :=
  fun y => if y =? x
        then Some (A:=(binary_float 53 1024)) v
        else E y.

21
Fixpoint eval_expr_float (e:expr (binary_float 53 1024)) (E:nat -> option fl64):=
22
23
24
25
  match e with
  | Var _ x => E x
  | Const m v => Some v
  | Unop Neg e =>
26
    match eval_expr_float e E with
27
28
29
30
31
    |Some v1 => Some (b64_opp v1)
    |_ => None
    end
  | Unop Inv e => None
  | Binop b e1 e2 =>
32
    match eval_expr_float e1 E, eval_expr_float e2 E with
33
34
    | Some f1, Some f2 =>
      match b with
Heiko Becker's avatar
Heiko Becker committed
35
36
37
38
      | Plus => Some (b64_plus dmode f1 f2)
      | Sub => Some (b64_minus dmode f1 f2)
      | Mult => Some (b64_mult dmode f1 f2)
      | Div => Some (b64_div dmode f1 f2)
39
40
41
      end
    |_ , _ => None
    end
Nikita Zyuzin's avatar
Nikita Zyuzin committed
42
  | Fma e1 e2 e3 =>
43
    match eval_expr_float e1 E, eval_expr_float e2 E, eval_expr_float e3 E with
44
      (* | Some f1, Some f2, Some f3 => Some (b64_plus dmode f1 (b64_mult dmode f2 f3)) *)
Nikita Zyuzin's avatar
Nikita Zyuzin committed
45
46
      | _, _, _ => None
    end
47
  | _ => None
48
49
  end.

Heiko Becker's avatar
Heiko Becker committed
50
51
Fixpoint bstep_float f E :option fl64 :=
  match f with
52
  | Let m x e g =>
53
    olet res :=  eval_expr_float e E in
54
        bstep_float g (updFlEnv x res E)
55
  | Ret e => eval_expr_float e E
Heiko Becker's avatar
Heiko Becker committed
56
57
58
  end.

Definition isValid e :=
59
60
  plet v := e in
        normal_or_zero (B2R 53 1024 v).
Heiko Becker's avatar
Heiko Becker committed
61

62
Fixpoint eval_expr_valid (e:expr fl64) E :=
63
  match e with
64
65
66
  | Var _ x => True (*isValid (eval_expr_float (Var n) E)*)
  | Const m v => True (*isValid (eval_expr_float (Const m v) E)*)
  | Unop u e => eval_expr_valid e E
Heiko Becker's avatar
Heiko Becker committed
67
  | Binop b e1 e2 =>
68
69
70
    (eval_expr_valid e1 E) /\ (eval_expr_valid e2 E) /\
    (let e1_res := eval_expr_float e1 E in
     let e2_res := eval_expr_float e2 E in
71
     optionBind e1_res
Heiko Becker's avatar
Heiko Becker committed
72
73
                (fun v1 =>
                   let v1_real := B2R 53 1024 v1 in
74
                   optionBind e2_res
Heiko Becker's avatar
Heiko Becker committed
75
76
77
78
79
                              (fun v2 =>
                                 let v2_real := B2R 53 1024 v2 in
                                 normal_or_zero (evalBinop b v1_real v2_real))
                              True)
                True)
Nikita Zyuzin's avatar
Nikita Zyuzin committed
80
  | Fma e1 e2 e3 =>
81
82
83
84
    (eval_expr_valid e1 E) /\ (eval_expr_valid e2 E) /\ (eval_expr_valid e3 E) /\
    (let e1_res := eval_expr_float e1 E in
     let e2_res := eval_expr_float e2 E in
     let e3_res := eval_expr_float e3 E in
85
     optionBind e1_res
Nikita Zyuzin's avatar
Nikita Zyuzin committed
86
87
                (fun v1 =>
                   let v1_real := B2R 53 1024 v1 in
88
                   optionBind e2_res
Nikita Zyuzin's avatar
Nikita Zyuzin committed
89
90
                              (fun v2 =>
                                 let v2_real := B2R 53 1024 v2 in
91
                                 optionBind e3_res
Nikita Zyuzin's avatar
Nikita Zyuzin committed
92
93
                                            (fun v3 =>
                                               let v3_real := B2R 53 1024 v3 in
94
95
96
                                               (* No support for fma yet *)
                                               (* normal_or_zero (evalFma v1_real v2_real v3_real)) *)
                                               False)
Nikita Zyuzin's avatar
Nikita Zyuzin committed
97
98
99
                                            True)
                              True)
                True)
100
  | Downcast m e => eval_expr_valid e E
101
102
  end.

Heiko Becker's avatar
Heiko Becker committed
103
104
Fixpoint bstep_valid f E :=
  match f with
105
  | Let m x e g =>
106
107
    eval_expr_valid e E /\
    (optionBind (eval_expr_float e E)
108
109
                (fun v_e => bstep_valid g (updFlEnv x v_e E))
                True)
110
  | Ret e => eval_expr_valid e E
Heiko Becker's avatar
Heiko Becker committed
111
112
113
114
115
116
117
118
119
120
121
122
  end.

Definition bpowQ (r:radix) (e: Z) :=
  match e with
  |0%Z => 1%Q
  | (' p)%Z => (Z.pow_pos r p) #1
  | Z.neg p => Qinv ((Z.pow_pos r p)#1)
  end.

Definition B2Q :=
  fun prec emax : Z =>
    let emin := (3 - emax - prec)%Z in
Heiko Becker's avatar
Heiko Becker committed
123
    let fexpr := Fcore_FLT.FLT_exp emin prec in
Heiko Becker's avatar
Heiko Becker committed
124
125
126
127
128
129
    fun f : binary_float prec emax =>
      match f with
      | B754_zero _ _ _ => 0%Q
      | B754_infinity _ _ _ => (bpowQ radix2 emax) +1%Q
      | B754_nan _ _ _ _ => (bpowQ radix2 emax) +1%Q
      | B754_finite _ _ s m e _ =>
Heiko Becker's avatar
Heiko Becker committed
130
131
        let f_new: Fcore_defs.float radix2 := {| Fcore_defs.Fnum := cond_Zopp s (' m); Fcore_defs.Fexp := e |} in
        (Fcore_defs.Fnum f_new # 1) * bpowQ radix2 (Fcore_defs.Fexp f_new)
Heiko Becker's avatar
Heiko Becker committed
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
      end.

Lemma B2Q_B2R_eq :
  forall v,
    is_finite 53 1024 v = true ->
    Q2R (B2Q v) = B2R 53 1024 v.
Proof.
  intros; unfold B2Q, B2R, is_finite in *.
  destruct v eqn:?; try congruence;
    try rewrite Q2R0_is_0; try lra.
  unfold Fcore_defs.F2R.
  rewrite Q2R_mult.
  f_equal.
  - unfold Z2R, Q2R.
    simpl. rewrite RMicromega.Rinv_1.
    destruct (cond_Zopp b (' m)); unfold IZR;
Heiko Becker's avatar
Heiko Becker committed
148
      try rewrite P2R_INR, INR_IPR; lra.
Heiko Becker's avatar
Heiko Becker committed
149
150
151
152
153
  - unfold Q2R; simpl.
    unfold bpow, bpowQ.
    destruct e; simpl; try lra.
    + rewrite RMicromega.Rinv_1.
      unfold Z2R, IZR.
Heiko Becker's avatar
Heiko Becker committed
154
      destruct (Z.pow_pos 2 p); try rewrite P2R_INR, INR_IPR; auto.
Heiko Becker's avatar
Heiko Becker committed
155
    + unfold Z2R, IZR. unfold Qinv; simpl.
Heiko Becker's avatar
Heiko Becker committed
156
      destruct (Z.pow_pos 2 p) eqn:? ; try rewrite P2R_INR, INR_IPR; simpl; try lra.
Heiko Becker's avatar
Heiko Becker committed
157
158
159
160
161
162
163
      * unfold bounded in e0.  simpl in e0. unfold canonic_mantissa in e0.
        simpl in e0.
        pose proof (Is_true_eq_left _ e0).
        apply Is_true_eq_true in H0; andb_to_prop H0.
        assert (0 < Z.pow_pos 2 p)%Z.
        { apply Zpower_pos_gt_0. cbv; auto. }
        rewrite Heqz in H0. inversion H0.
Heiko Becker's avatar
Heiko Becker committed
164
165
166
167
168
      * unfold IPR at 1. rewrite Rmult_1_l; auto.
      * rewrite <- Ropp_mult_distr_l, Ropp_mult_distr_r, Ropp_inv_permute;
        [ unfold IPR at 1; lra | ].
        hnf; intros. pose proof (pos_INR_nat_of_P p0).
        rewrite INR_IPR in *.
Heiko Becker's avatar
Heiko Becker committed
169
170
171
        rewrite H0 in H1; lra.
Qed.

172
Fixpoint B2Qexpr (e: expr fl64) :=
Heiko Becker's avatar
Heiko Becker committed
173
174
175
  match e with
  | Var _ x =>  Var Q x
  | Const m v => Const m (B2Q v)
176
177
178
179
  | Unop u e => Unop u (B2Qexpr e)
  | Binop b e1 e2 => Binop b (B2Qexpr e1) (B2Qexpr e2)
  | Fma e1 e2 e3 => Fma (B2Qexpr e1) (B2Qexpr e2) (B2Qexpr e3)
  | Downcast m e => Downcast m (B2Qexpr e)
Heiko Becker's avatar
Heiko Becker committed
180
181
182
183
  end.

Fixpoint B2Qcmd (f:cmd fl64) :=
  match f with
184
185
  | Let m x e g => Let m x (B2Qexpr e) (B2Qcmd g)
  | Ret e => Ret (B2Qexpr e)
Heiko Becker's avatar
Heiko Becker committed
186
187
188
189
190
191
192
193
  end.

Definition toREnv (E: nat -> option fl64) (x:nat):option R :=
  match E x with
  |Some v => Some (Q2R (B2Q v))
  |_ => None
  end.

194
Fixpoint is64BitEval (V:Type) (e:expr V) :=
Heiko Becker's avatar
Heiko Becker committed
195
196
197
198
199
  match e with
  | Var _ x => True
  | Const m e => m = M64
  | Unop u e => is64BitEval e
  | Binop b e1 e2 => is64BitEval e1 /\ is64BitEval e2
Nikita Zyuzin's avatar
Nikita Zyuzin committed
200
  | Fma e1 e2 e3 => is64BitEval e1 /\ is64BitEval e2 /\ is64BitEval e3
Heiko Becker's avatar
Heiko Becker committed
201
202
203
204
205
206
207
208
209
  | Downcast m e => m = M64 /\ is64BitEval e
  end.

Fixpoint is64BitBstep (V:Type) (f:cmd V) :=
  match f with
  | Let m x e g => is64BitEval e /\ m = M64 /\ is64BitBstep g
  | Ret e => is64BitEval e
  end.

210
Fixpoint noDowncast (V:Type) (e:expr V) :=
Heiko Becker's avatar
Heiko Becker committed
211
212
213
214
215
  match e with
  | Var _ x => True
  | Const m e => True
  | Unop u e => noDowncast e
  | Binop b e1 e2 => noDowncast e1 /\ noDowncast e2
Nikita Zyuzin's avatar
Nikita Zyuzin committed
216
  | Fma e1 e2 e3 => noDowncast e1 /\ noDowncast e2 /\ noDowncast e3
Heiko Becker's avatar
Heiko Becker committed
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
  | Downcast m e => False
  end.

Fixpoint noDowncastFun (V:Type) (f:cmd V) :=
  match f with
  | Let m x e g => noDowncast e /\ noDowncastFun g
  | Ret e => noDowncast e
  end.

Opaque mTypeToQ.

Lemma validValue_is_finite v:
  validFloatValue (Q2R (B2Q v)) M64 -> is_finite 53 1024 v = true.
Proof.
  intros validVal.
  unfold is_finite.
  unfold validFloatValue, B2Q in *.
  destruct v; try auto;
    destruct validVal; unfold Normal in *; unfold Denormal in *;
236
      unfold maxValue, minValue_pos, maxExponent, minExponentPos in*;
Heiko Becker's avatar
Heiko Becker committed
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
      rewrite Q2R_inv in *; unfold bpowQ in *.
  - assert (Z.pow_pos radix2 1024 = 179769313486231590772930519078902473361797697894230657273430081157732675805500963132708477322407536021120113879871393357658789768814416622492847430639474124377767893424865485276302219601246094119453082952085005768838150682342462881473913110540827237163350510684586298239947245938479716304835356329624224137216%Z)
      by (vm_compute;auto).
    rewrite H0 in H; destruct H; try lra.
    assert (Z.pow_pos 2 1023 = 89884656743115795386465259539451236680898848947115328636715040578866337902750481566354238661203768010560056939935696678829394884407208311246423715319737062188883946712432742638151109800623047059726541476042502884419075341171231440736956555270413618581675255342293149119973622969239858152417678164812112068608%Z)
      by (vm_compute; auto).
    rewrite H2 in *.
    clear H0 H2.
    rewrite Rabs_right in H1.
    apply Rle_Qle in H1.
    + rewrite <- Qle_bool_iff in H1.
      cbv in H1; try congruence.
    + rewrite <- Q2R0_is_0.
      apply Rle_ge. apply Qle_Rle; rewrite <- Qle_bool_iff; cbv; auto.
  - vm_compute; intros; congruence.
  - destruct H.
    + destruct H. rewrite Rabs_right in H.
      * rewrite <- Q2R_inv in H.
        apply Rlt_Qlt in H.
        vm_compute in H.
        congruence.
        vm_compute; congruence.
      * rewrite <- Q2R0_is_0.
        apply Rle_ge. apply Qle_Rle; rewrite <- Qle_bool_iff; cbv; auto.
    + rewrite <- Q2R0_is_0 in H.
      apply eqR_Qeq in H.
      vm_compute in H; congruence.
  - vm_compute; congruence.
  - destruct H.
    rewrite Rabs_right in H0.
    + apply Rle_Qle in H0.
      rewrite <- Qle_bool_iff in H0.
      vm_compute in H0; auto.
    + rewrite <- Q2R0_is_0.
      apply Rle_ge. apply Qle_Rle; rewrite <- Qle_bool_iff; cbv; auto.
  - vm_compute; congruence.
  - destruct H.
    + rewrite Rabs_right in H.
      * destruct H. rewrite <- Q2R_inv in H.
        { apply Rlt_Qlt in H. rewrite Qlt_alt in H.
          vm_compute in H. congruence. }
        { vm_compute; congruence. }
      * rewrite <- Q2R0_is_0.
        apply Rle_ge. apply Qle_Rle; rewrite <- Qle_bool_iff; cbv; auto.
    + rewrite <- Q2R0_is_0 in H.
      apply eqR_Qeq in H. vm_compute in H; congruence.
  - vm_compute; congruence.
Qed.

286
Lemma typing_expr_64_bit e:
Heiko Becker's avatar
Heiko Becker committed
287
288
289
290
291
292
  forall Gamma tMap,
    noDowncast e ->
    is64BitEval e ->
    typeCheck e Gamma tMap = true ->
    (forall v,
        NatSet.In v (usedVars e) -> Gamma v = Some M64) ->
293
    FloverMap.find e tMap = Some M64.
Heiko Becker's avatar
Heiko Becker committed
294
295
Proof.
  induction e; intros * noDowncast_e is64BitEval_e typecheck_e types_valid;
Heiko Becker's avatar
Heiko Becker committed
296
    cbn in *; try inversion noDowncast_e;
297
      subst; Flover_compute; try congruence;
Heiko Becker's avatar
Heiko Becker committed
298
299
300
301
        type_conv; subst.
  - rewrite types_valid in *; try set_tac.
  - destruct m; try congruence.
  - erewrite IHe in *; eauto.
Heiko Becker's avatar
Heiko Becker committed
302
303
304
305
306
  - repeat (match goal with
            |H: _ /\ _ |- _=> destruct H
            end).
      erewrite IHe1 in *; eauto.
    + erewrite IHe2 in *; eauto.
Heiko Becker's avatar
Heiko Becker committed
307
308
309
310
      * unfold join in *.
        destr_factorize.
        rewrite <- isMorePrecise_morePrecise.
        rewrite isMorePrecise_refl. inversion Heqo0; auto.
Heiko Becker's avatar
Heiko Becker committed
311
312
313
      * intros.
        apply types_valid. set_tac.
    + intros; apply types_valid; set_tac.
Nikita Zyuzin's avatar
Nikita Zyuzin committed
314
315
316
  - repeat (match goal with
            |H: _ /\ _ |- _=> destruct H
            end).
317
318
319
320
321
322
323
324
    erewrite IHe1 in *; eauto; try (intros; apply types_valid; set_tac; fail).
    erewrite IHe2 in *; eauto; try (intros; apply types_valid; set_tac; fail).
    unfold join3, join in *.
    erewrite IHe3 in *; eauto; try (intros; apply types_valid; set_tac; fail).
    repeat destr_factorize.
    repeat rewrite <- isMorePrecise_morePrecise.
    repeat rewrite isMorePrecise_refl;
      type_conv; subst; auto.
Heiko Becker's avatar
Heiko Becker committed
325
326
327
328
329
330
331
332
333
Qed.

Lemma typing_cmd_64_bit f:
  forall Gamma tMap,
    noDowncastFun f ->
    is64BitBstep f ->
    typeCheckCmd f Gamma tMap = true ->
    (forall v,
        NatSet.In v (freeVars f) -> Gamma v = Some M64) ->
334
    FloverMap.find (getRetExp f) tMap = Some M64.
Heiko Becker's avatar
Heiko Becker committed
335
336
Proof.
  induction f; intros * noDowncast_f is64BitEval_f typecheck_f types_valid;
Heiko Becker's avatar
Heiko Becker committed
337
    cbn in *;
338
    subst; try eauto using typing_expr_64_bit;
339
      Flover_compute; try congruence.
Heiko Becker's avatar
Heiko Becker committed
340
341
342
343
344
345
346
347
348
349
350
351
  destruct noDowncast_f; destruct is64BitEval_f as [Ha [Hb Hc]].
  eapply IHf; eauto.
  intros. unfold updDefVars.
  destruct (v =? n) eqn:?.
  - type_conv; auto.
  - apply types_valid.
    rewrite NatSet.remove_spec, NatSet.union_spec.
    split; try auto.
    hnf; intros; subst. rewrite Nat.eqb_neq in Heqb.
    congruence.
Qed.

352
Lemma typing_agrees_expr e:
Heiko Becker's avatar
Heiko Becker committed
353
354
  forall E Gamma tMap v m1 m2,
    typeCheck e Gamma tMap = true ->
355
    eval_expr E Gamma (toRExp e) v m1 ->
356
    FloverMap.find e tMap = Some m2 ->
Heiko Becker's avatar
Heiko Becker committed
357
358
    m1 = m2.
Proof.
Heiko Becker's avatar
Heiko Becker committed
359
  induction e; intros * typeCheck_e eval_e tMap_e; cbn in *;
Heiko Becker's avatar
Heiko Becker committed
360
    rewrite tMap_e in *;
Heiko Becker's avatar
Heiko Becker committed
361
    inversion eval_e; subst; cbn in *;
362
      Flover_compute; try congruence; type_conv; subst; try auto.
Heiko Becker's avatar
Heiko Becker committed
363
364
  - eapply IHe; eauto.
  - eapply IHe; eauto.
365
366
  - assert (m0 = m) by eauto using IHe1.
    assert (m3 = m1) by eauto using IHe2.
Heiko Becker's avatar
Heiko Becker committed
367
    subst; auto.
368
369
370
  - assert (m0 = m) by eauto using IHe1.
    assert (m3 = m1) by eauto using IHe2.
    assert (m4 = m5) by eauto using IHe3.
Nikita Zyuzin's avatar
Nikita Zyuzin committed
371
    subst; auto.
Heiko Becker's avatar
Heiko Becker committed
372
373
374
375
376
377
Qed.

Lemma typing_agrees_cmd f:
  forall E Gamma tMap v m1 m2,
    typeCheckCmd f Gamma tMap = true ->
    bstep (toRCmd f) E Gamma v m1 ->
378
    FloverMap.find (getRetExp f) tMap = Some m2 ->
Heiko Becker's avatar
Heiko Becker committed
379
380
    m1 = m2.
Proof.
Heiko Becker's avatar
Heiko Becker committed
381
  induction f; intros * typeCheck_f eval_f tMap_f; cbn in *;
382
    Flover_compute; try congruence; type_conv; subst.
Heiko Becker's avatar
Heiko Becker committed
383
  - inversion eval_f; subst; simpl in *.
Heiko Becker's avatar
Heiko Becker committed
384
385
    specialize (IHf (updEnv n v0 E) (updDefVars n m3 Gamma) tMap v m1 m2).
    apply IHf; auto.
386
  - inversion eval_f; subst; eapply typing_agrees_expr; eauto.
Heiko Becker's avatar
Heiko Becker committed
387
388
389
Qed.

Lemma round_0_zero:
Heiko Becker's avatar
Heiko Becker committed
390
  (Fcore_generic_fmt.round radix2 (Fcore_FLT.FLT_exp (3 - 1024 - 53) 53)
Heiko Becker's avatar
Heiko Becker committed
391
392
393
394
395
396
397
398
399
400
401
402
403
404
                           (round_mode mode_NE) 0) = 0%R.
Proof.
  unfold Fcore_generic_fmt.round. simpl.
  unfold Fcore_generic_fmt.scaled_mantissa.
  rewrite Rmult_0_l.
  unfold Fcore_generic_fmt.Znearest.
  unfold Zfloor.
  assert (up 0 = 1%Z).
  { symmetry. apply tech_up; lra. }
  rewrite H.
  simpl. rewrite Rsub_eq_Ropp_Rplus. rewrite Rplus_opp_r.
  assert (Rcompare (0) (/ 2) = Lt).
  { apply Rcompare_Lt. lra. }
  rewrite H0.
Heiko Becker's avatar
Heiko Becker committed
405
  unfold Fcore_generic_fmt.canonic_exp.
Heiko Becker's avatar
Heiko Becker committed
406
407
408
409
410
411
412
413
414
415
416
417
418
  unfold Fcore_defs.F2R; simpl.
  rewrite Rmult_0_l. auto.
Qed.

Lemma validValue_bounded b v_e1 v_e2:
  (Normal (evalBinop b (B2R 53 1024 v_e1) (B2R 53 1024 v_e2)) M64\/
   ((evalBinop b (B2R 53 1024 v_e1) (B2R 53 1024 v_e2)) = 0)%R) ->
  (forall eps, (Rabs eps <= / 2 * bpow radix2 (- 53 + 1))%R ->
  validFloatValue ((evalBinop b (B2R 53 1024 v_e1) (B2R 53 1024 v_e2)) * (1 + eps)) M64) ->
  Rlt_bool
    (Rabs
       (Fcore_generic_fmt.round
          radix2
Heiko Becker's avatar
Heiko Becker committed
419
          (Fcore_FLT.FLT_exp (3 - 1024 - 53) 53)
Heiko Becker's avatar
Heiko Becker committed
420
421
422
423
424
          (round_mode mode_NE)
          (evalBinop b (B2R 53 1024 v_e1) (B2R 53 1024 v_e2))))
    (bpow radix2 1024) = true.
Proof.
  simpl.
Heiko Becker's avatar
Heiko Becker committed
425
  pose proof (fexp_correct 53 1024 eq_refl) as fexpr_corr.
Heiko Becker's avatar
Heiko Becker committed
426
  assert (forall k : Z, (-1022 < k)%Z ->
Heiko Becker's avatar
Heiko Becker committed
427
                     (53 <= k - Fcore_FLT.FLT_exp (3 - 1024 - 53) 53 k)%Z)
428
    as expr_valid.
Heiko Becker's avatar
Heiko Becker committed
429
  { intros k k_pos.
Heiko Becker's avatar
Heiko Becker committed
430
    unfold Fcore_FLT.FLT_exp; simpl.
Heiko Becker's avatar
Heiko Becker committed
431
    destruct (Z.max_spec_le (k - 53) (-1074)); omega. }
Heiko Becker's avatar
Heiko Becker committed
432
  pose proof (relative_error_N_ex radix2 (Fcore_FLT.FLT_exp (3 -1024 - 53) 53)
433
                                  (-1022)%Z 53%Z expr_valid)
Heiko Becker's avatar
Heiko Becker committed
434
435
436
437
438
439
440
441
    as rel_error_exists.
  intros [normal_v | zero_v] validVal;
  apply Rlt_bool_true.
  - unfold Normal in *; destruct normal_v.
    specialize (rel_error_exists (fun x => negb (Zeven x))
                                 (evalBinop b (B2R 53 1024 v_e1) (B2R 53 1024 v_e2))%R).
    destruct (rel_error_exists) as [eps [bounded_eps round_eq]].
    + eapply Rle_trans; eauto.
442
      unfold minValue_pos, Z.pow_pos; simpl.
Heiko Becker's avatar
Heiko Becker committed
443
444
445
446
447
448
449
450
451
452
453
454
455
      rewrite Q2R_inv.
      * apply Rinv_le.
        { rewrite <- Q2R0_is_0. apply Qlt_Rlt.
          apply Qlt_alt. vm_compute; auto. }
        { unfold Q2R.
          unfold Qnum, Qden. lra. }
      *  vm_compute; congruence.
    + simpl in *.
      rewrite round_eq.
      destruct (validVal eps) as [normal_v | [denormal_v | zero_v]]; try auto.
      * unfold Normal in *. destruct normal_v.
        eapply Rle_lt_trans; eauto.
        unfold maxValue, bpow. unfold maxExponent. unfold Q2R.
Heiko Becker's avatar
Heiko Becker committed
456
457
        unfold Qnum, Qden. rewrite <- Z2R_IZR. unfold IZR.
        repeat rewrite <- INR_IPR. simpl. lra.
Heiko Becker's avatar
Heiko Becker committed
458
459
      * unfold Denormal in *. destruct denormal_v.
        eapply Rlt_trans; eauto.
460
        unfold minValue_pos, minExponentPos, bpow.
Heiko Becker's avatar
Heiko Becker committed
461
462
        rewrite Q2R_inv.
        { unfold Q2R, Qnum, Qden.
Heiko Becker's avatar
Heiko Becker committed
463
464
          rewrite <- Z2R_IZR; unfold IZR.
          repeat rewrite <- INR_IPR; simpl; lra. }
Heiko Becker's avatar
Heiko Becker committed
465
        { vm_compute; congruence. }
Heiko Becker's avatar
Heiko Becker committed
466
      * rewrite zero_v. simpl. rewrite Rabs_R0. lra.
Heiko Becker's avatar
Heiko Becker committed
467
468
469
  - rewrite zero_v.
    pose proof round_0_zero. simpl in H. rewrite H.
    rewrite Rabs_R0.
Heiko Becker's avatar
Heiko Becker committed
470
    lra.
Heiko Becker's avatar
Heiko Becker committed
471
472
Qed.

473
(* (fexpr_correct 53 1024 eq_refl) as fexpr_corr. *)
Heiko Becker's avatar
Heiko Becker committed
474
(* (relative_error_N_ex radix2 (Fcore_FLT.FLT_exp (3 -1024 - 53) 53) *)
475
(*                                     (-1022)%Z 53%Z) *)
476
Lemma eval_expr_gives_IEEE (e:expr fl64) :
Heiko Becker's avatar
Heiko Becker committed
477
478
  forall E1 E2 E2_real Gamma tMap vR A P fVars dVars,
    (forall x, (toREnv E2) x = E2_real x) ->
479
    typeCheck (B2Qexpr e) Gamma tMap = true ->
Heiko Becker's avatar
Heiko Becker committed
480
    approxEnv E1 Gamma A fVars dVars E2_real ->
481
482
483
484
485
486
487
488
    validIntervalbounds (B2Qexpr e) A P dVars = true ->
    validErrorbound (B2Qexpr e) tMap A dVars = true ->
    FPRangeValidator (B2Qexpr e) A tMap dVars = true ->
    eval_expr (toREnv E2) Gamma (toRExp (B2Qexpr e)) vR M64 ->
    NatSet.Subset ((usedVars (B2Qexpr e)) -- dVars) fVars ->
    is64BitEval (B2Qexpr e) ->
    noDowncast (B2Qexpr e) ->
    eval_expr_valid e E2 ->
Heiko Becker's avatar
Heiko Becker committed
489
490
491
    dVars_range_valid dVars E1 A ->
    fVars_P_sound fVars E1 P ->
    vars_typed (NatSet.union fVars dVars) Gamma ->
Heiko Becker's avatar
Heiko Becker committed
492
493
494
      (forall v,
        NatSet.In v dVars ->
        exists vF m,
495
        (E2_real v = Some vF /\ FloverMap.find (Var Q v) tMap = Some m /\
Heiko Becker's avatar
Heiko Becker committed
496
        validFloatValue vF m)) ->
497
      (forall v, NatSet.In v (usedVars (B2Qexpr e)) -> Gamma v = Some M64) ->
Heiko Becker's avatar
Heiko Becker committed
498
      exists v,
499
500
        eval_expr_float e E2 = Some v /\
        eval_expr (toREnv E2) Gamma (toRExp (B2Qexpr e)) (Q2R (B2Q v)) M64.
501
Proof.
502
   induction e; simpl in *;
Heiko Becker's avatar
Heiko Becker committed
503
504
505
506
507
    intros * envs_eq typecheck_e approxEnv_E1_E2_real valid_rangebounds
                     valid_roundoffs valid_float_ranges eval_e_float
                     usedVars_sound is64BitEval_e noDowncast_e eval_IEEE_valid_e
                     fVars_defined vars_typed dVars_sound dVars_valid
                     usedVars_64bit;
508
    (match_pat (eval_expr _ _ _ _ _) (fun H => inversion H; subst; simpl in *));
509
     Flover_compute_asm; try congruence; type_conv; subst;
510
     unfold optionBind.
Heiko Becker's avatar
Heiko Becker committed
511
512
513
514
515
  - unfold toREnv in *.
    destruct (E2 n) eqn:HE2; try congruence.
    exists f; split; try eauto.
    eapply Var_load; try auto. rewrite HE2; auto.
  - eexists; split; try eauto.
516
517
    eapply (Const_dist') with (delta:=0%R); eauto.
    + rewrite Rabs_R0; apply mTypeToR_pos_R.
Heiko Becker's avatar
Heiko Becker committed
518
519
    + unfold perturb. lra.
  - edestruct IHe as [v_e [eval_float_e eval_rel_e]]; eauto.
Heiko Becker's avatar
Heiko Becker committed
520
521
522
523
524
525
526
527
528
529
    assert (is_finite 53 1024 v_e = true).
    { apply validValue_is_finite.
      eapply FPRangeValidator_sound; eauto.
      eapply eval_eq_env; eauto. }
    rewrite eval_float_e.
    exists (b64_opp v_e); split; try auto.
    unfold b64_opp. rewrite <- (is_finite_Bopp _ _ pair) in H.
    rewrite B2Q_B2R_eq; auto. rewrite B2R_Bopp.
    eapply Unop_neg'; eauto.
    unfold evalUnop. rewrite is_finite_Bopp in H. rewrite B2Q_B2R_eq; auto.
Heiko Becker's avatar
Heiko Becker committed
530
531
532
  - repeat (match goal with
            |H: _ /\ _ |- _ => destruct H
            end).
533
534
535
    assert (FloverMap.find (B2Qexpr e1) tMap = Some M64 /\
            FloverMap.find (B2Qexpr e2) tMap = Some M64 /\
            FloverMap.find (Binop b (B2Qexpr e1) (B2Qexpr e2)) tMap = Some M64)
Heiko Becker's avatar
Heiko Becker committed
536
           as [tMap_e1 [tMap_e2 tMap_b]].
537
    { repeat split; apply (typing_expr_64_bit _ Gamma); simpl; auto.
Heiko Becker's avatar
Heiko Becker committed
538
539
      - intros; apply usedVars_64bit; set_tac.
      - intros; apply usedVars_64bit; set_tac.
540
      - rewrite Heqo1, Heqo6, Heqo8.
Heiko Becker's avatar
Heiko Becker committed
541
542
543
544
        apply Is_true_eq_true; apply andb_prop_intro; split.
        + apply andb_prop_intro; split; apply Is_true_eq_left; auto.
          apply mTypeEq_refl.
        + apply Is_true_eq_left; auto. }
Heiko Becker's avatar
Heiko Becker committed
545
    repeat destr_factorize.
Heiko Becker's avatar
Heiko Becker committed
546
    assert (m1 = M64).
547
    { eapply (typing_agrees_expr (B2Qexpr e1)); eauto. }
Heiko Becker's avatar
Heiko Becker committed
548
    assert (m2 = M64).
549
    { eapply typing_agrees_expr; eauto. }
Heiko Becker's avatar
Heiko Becker committed
550
551
552
553
554
555
556
557
558
    subst.
    destruct (IHe1 E1 E2 E2_real Gamma tMap v1 A P fVars dVars)
      as [v_e1 [eval_float_e1 eval_rel_e1]];
      try auto; try set_tac;
        [ intros; apply usedVars_64bit ; set_tac | ].
    destruct (IHe2 E1 E2 E2_real Gamma tMap v2 A P fVars dVars)
      as [v_e2 [eval_float_e2 eval_rel_e2]];
      try auto; try set_tac;
        [ intros; apply usedVars_64bit ; set_tac | ].
559
    (* rewrite eval_float_e1, eval_float_e2. *)
560
    edestruct (validIntervalbounds_sound (B2Qexpr e2))
Heiko Becker's avatar
Heiko Becker committed
561
562
563
564
      as [iv_2 [err_2 [nR2 [map_e2 [eval_real_e2 e2_bounded_real]]]]];
      eauto; set_tac.
    destr_factorize.
    destruct iv_2 as [ivlo_2 ivhi_2].
Heiko Becker's avatar
Heiko Becker committed
565
    assert (forall vF2 m2,
566
               eval_expr E2_real Gamma (toRExp (B2Qexpr e2)) vF2 m2 ->
Heiko Becker's avatar
Heiko Becker committed
567
568
               (Rabs (nR2 - vF2) <= Q2R err_2))%R.
    { eapply validErrorbound_sound; try eauto; try set_tac. }
Heiko Becker's avatar
Heiko Becker committed
569
570
    assert (contained (Q2R (B2Q v_e2))
                      (widenInterval
Heiko Becker's avatar
Heiko Becker committed
571
                         (Q2R ivlo_2, Q2R ivhi_2) (Q2R err_2))).
Heiko Becker's avatar
Heiko Becker committed
572
573
574
575
576
577
    { eapply distance_gives_iv.
      - simpl. eapply e2_bounded_real.
      - eapply H11. instantiate(1:=M64).
        eapply eval_eq_env; eauto. }
    assert (b = Div -> (Q2R (B2Q v_e2)) <> 0%R).
    { intros; subst; simpl in *.
Heiko Becker's avatar
Heiko Becker committed
578
579
580
      andb_to_prop R3.
      apply le_neq_bool_to_lt_prop in L3.
      destruct L3; hnf; intros.
Heiko Becker's avatar
Heiko Becker committed
581
582
583
584
585
586
587
588
      - rewrite H15 in *.
        apply Qlt_Rlt in H14.
        rewrite Q2R0_is_0, Q2R_plus in H14. lra.
      - rewrite H15 in *.
        apply Qlt_Rlt in H14.
        rewrite Q2R0_is_0, Q2R_minus in H14; lra. }
    assert (validFloatValue
              (evalBinop b (Q2R (B2Q v_e1)) (Q2R (B2Q v_e2))) M64).
589
    { eapply (FPRangeValidator_sound (Binop b (B2Qexpr e1) (B2Qexpr e2)));
Heiko Becker's avatar
Heiko Becker committed
590
591
        try eauto; set_tac.
      - eapply eval_eq_env; eauto.
592
593
        eapply Binop_dist' with (delta:=0%R); eauto.
        + rewrite Rabs_R0. apply mTypeToR_pos_R.
Heiko Becker's avatar
Heiko Becker committed
594
        + unfold perturb; lra.
595
      - Flover_compute.
Heiko Becker's avatar
Heiko Becker committed
596
597
        apply Is_true_eq_true.
        repeat (apply andb_prop_intro); split; try auto using Is_true_eq_left.
598
      - Flover_compute.
Heiko Becker's avatar
Heiko Becker committed
599
600
601
        apply Is_true_eq_true.
        repeat (apply andb_prop_intro); split; try auto using Is_true_eq_left.
        apply andb_prop_intro; split; auto using Is_true_eq_left.
602
      - inversion Heqo3; subst. Flover_compute.
Heiko Becker's avatar
Heiko Becker committed
603
604
        apply Is_true_eq_true.
        repeat (apply andb_prop_intro; split); try auto using Is_true_eq_left.
605
606
        apply Is_true_eq_left. inversion Heqo4; subst. auto.
      - rewrite Heqo1, Heqo2.
Heiko Becker's avatar
Heiko Becker committed
607
        apply Is_true_eq_true.
608
        inversion Heqo3; inversion Heqo4; subst.
Heiko Becker's avatar
Heiko Becker committed
609
610
        repeat (apply andb_prop_intro; split); try auto using Is_true_eq_left. }
    assert (validFloatValue (Q2R (B2Q v_e1)) M64).
611
    { eapply (FPRangeValidator_sound (B2Qexpr e1)); try eauto; try set_tac.
Heiko Becker's avatar
Heiko Becker committed
612
613
      eapply eval_eq_env; eauto. }
    assert (validFloatValue (Q2R (B2Q v_e2)) M64).
614
    { eapply (FPRangeValidator_sound (B2Qexpr e2)); try eauto; try set_tac.
Heiko Becker's avatar
Heiko Becker committed
615
616
617
618
619
620
621
622
623
624
      - eapply eval_eq_env; eauto. }
    assert (is_finite 53 1024 v_e1 = true) as finite_e1.
    { apply validValue_is_finite; simpl; auto. }
    assert (is_finite 53 1024 v_e2 = true) as finite_e2.
    { apply validValue_is_finite; simpl; auto. }
    assert (forall eps,
               (Rabs eps <= / 2 * bpow radix2 (- 53 + 1))%R ->
               validFloatValue
                 (evalBinop b (B2R 53 1024 v_e1) (B2R 53 1024 v_e2) * (1 + eps)) M64).
    { intros.
625
      eapply FPRangeValidator_sound with (e:=Binop b (B2Qexpr e1) (B2Qexpr e2)); eauto.
Heiko Becker's avatar
Heiko Becker committed
626
627
      - eapply eval_eq_env; eauto.
        eapply Binop_dist' with (delta:=eps); eauto.
628
629
630
631
        + simpl in H2. Transparent mTypeToQ. unfold mTypeToQ.
          eapply Rle_trans; eauto.
          simpl. lra.
        + unfold perturb. repeat rewrite B2Q_B2R_eq; try auto.
632
      - cbn. Flover_compute.
Heiko Becker's avatar
Heiko Becker committed
633
634
        apply Is_true_eq_true.
        repeat (apply andb_prop_intro; split; try auto using Is_true_eq_left).
635
      - cbn. Flover_compute.
Heiko Becker's avatar
Heiko Becker committed
636
637
        apply Is_true_eq_true.
        repeat (apply andb_prop_intro; split; try auto using Is_true_eq_left).
638
      - cbn. Flover_compute.
639
        inversion Heqo3; inversion Heqo4; subst.
Heiko Becker's avatar
Heiko Becker committed
640
641
        apply Is_true_eq_true.
        repeat (apply andb_prop_intro; split; try auto using Is_true_eq_left).
642
      - cbn. Flover_compute.
643
        inversion Heqo3; inversion Heqo4; subst.
Heiko Becker's avatar
Heiko Becker committed
644
645
646
647
        apply Is_true_eq_true.
        repeat (apply andb_prop_intro; split; try auto using Is_true_eq_left). }
    assert (b = Div -> (Q2R (B2Q v_e2)) <> 0%R) as no_div_zero_float.
    { intros; subst; simpl in *.
648
649
650
      andb_to_prop R3.
      apply le_neq_bool_to_lt_prop in L3.
      destruct L3 as [case_low | case_high]; hnf; intros.
Heiko Becker's avatar
Heiko Becker committed
651
652
653
654
655
656
657
      - rewrite H19 in *.
        apply Qlt_Rlt in case_low.
        rewrite Q2R0_is_0, Q2R_plus in case_low. lra.
      - rewrite H19 in *.
        apply Qlt_Rlt in case_high.
        rewrite Q2R0_is_0, Q2R_minus in case_high; lra. }
    clear H2 H12 dVars_sound dVars_valid usedVars_64bit vars_typed fVars_defined
658
    usedVars_sound R2 R1 L1 L R6 L0 R3 R4 L2 R5 R7 L5 Heqo Heqo0 Heqo1 IHe1
Heiko Becker's avatar
Heiko Becker committed
659
    IHe2.
Heiko Becker's avatar
Heiko Becker committed
660
    pose proof (fexp_correct 53 1024 eq_refl) as fexpr_corr.
Heiko Becker's avatar
Heiko Becker committed
661
    assert (forall k : Z, (-1022 < k)%Z ->
Heiko Becker's avatar
Heiko Becker committed
662
                     (53 <= k - Fcore_FLT.FLT_exp (3 - 1024 - 53) 53 k)%Z)
663
      as expr_valid.
Heiko Becker's avatar
Heiko Becker committed
664
    { intros k k_pos.
Heiko Becker's avatar
Heiko Becker committed
665
      unfold Fcore_FLT.FLT_exp; simpl.
Heiko Becker's avatar
Heiko Becker committed
666
      destruct (Z.max_spec_le (k - 53) (-1074)); omega. }
Heiko Becker's avatar
Heiko Becker committed
667
    pose proof (relative_error_N_ex radix2 (Fcore_FLT.FLT_exp (3 -1024 - 53) 53)
668
                                    (-1022)%Z 53%Z expr_valid)
Heiko Becker's avatar
Heiko Becker committed
669
      as rel_error_exists.
670
    (* rewrite eval_float_e1, eval_float_e2 in H1. *)
671
    unfold optionBind, normal_or_zero in *; simpl in *.
Heiko Becker's avatar
Heiko Becker committed
672
673
674
675
676
677
678
679
    assert (Normal (evalBinop b (B2R 53 1024 v_e1) (B2R 53 1024 v_e2)) M64 \/
            (evalBinop b (B2R 53 1024 v_e1) (B2R 53 1024 v_e2)) = 0)%R.
    { revert H1; intros case_val. destruct case_val; try auto.
      left; unfold Normal, Denormal in H15; unfold Normal;
        destruct H15 as [normal_b | [denormal_b |zero_b]].
      - repeat rewrite <- B2Q_B2R_eq; try auto.
      - destruct denormal_b.
        assert ((Rabs (evalBinop b (Q2R (B2Q v_e1)) (Q2R (B2Q v_e2)))) < (Rabs (evalBinop b (Q2R (B2Q v_e1)) (Q2R (B2Q v_e2)))))%R.
680
        { eapply Rlt_le_trans with (r2 := 0); eauto.
Heiko Becker's avatar
Heiko Becker committed
681
682
683
684
685
686
          repeat rewrite B2Q_B2R_eq; auto. }
        lra.
      - rewrite B2Q_B2R_eq in zero_b; auto.
        rewrite B2Q_B2R_eq in zero_b; auto.
        rewrite zero_b in *.
        rewrite Rabs_R0 in H1.
687
        unfold minValue_pos, minExponentPos in H1.
Heiko Becker's avatar
Heiko Becker committed
688
689
690
691
692
        rewrite Q2R_inv in H1; [|vm_compute; congruence].
        unfold Q2R, Qnum, Qden in H1.
        assert (Z.pow_pos 2 1022 = 44942328371557897693232629769725618340449424473557664318357520289433168951375240783177119330601884005280028469967848339414697442203604155623211857659868531094441973356216371319075554900311523529863270738021251442209537670585615720368478277635206809290837627671146574559986811484619929076208839082406056034304%Z)
          by (vm_compute; auto).
        rewrite H2 in H1. rewrite <- Z2R_IZR in H1.  unfold IZR in H1.
Heiko Becker's avatar
Heiko Becker committed
693
        simpl in H1. rewrite <- INR_IPR in H1. simpl in H1. lra. }
Heiko Becker's avatar
Heiko Becker committed
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
    pose proof (validValue_bounded b v_e1 v_e2 H2 H18) as cond_valid.
    destruct b; revert H1; intros case_eval.
    (* Addition *)
    + unfold evalBinop in *. unfold b64_plus.
      pose proof (Bplus_correct 53 1024 eq_refl eq_refl binop_nan_pl64 mode_NE
                                v_e1 v_e2 finite_e1 finite_e2)
        as addition_correct.
      rewrite cond_valid in addition_correct.
      destruct addition_correct as [add_round [finite_res _]].
      destruct case_eval as [eval_zero | eval_normal].
      (* resutl is zero *)
      * rewrite eval_zero in *.
        rewrite round_0_zero in *.
        exists (Bplus 53 1024 eq_refl eq_refl binop_nan_pl64 dmode v_e1 v_e2).
        split; try auto.
        rewrite B2Q_B2R_eq; try auto.
        unfold dmode; rewrite add_round.
        eapply Binop_dist' with (delta:=0%R); eauto.
712
713
714
        { rewrite Rabs_R0; apply mTypeToR_pos_R. }
        { unfold perturb, evalBinop. cbn.
        repeat rewrite B2Q_B2R_eq; try auto; lra. }
Heiko Becker's avatar
Heiko Becker committed
715
716
717
718
719
      * simpl in *.
        destruct (rel_error_exists
                    (fun x => negb (Zeven x))
                    (B2R 53 1024 v_e1 + B2R 53 1024 v_e2)%R)
          as [eps [eps_bounded round_eq]].
720
        { eapply Rle_trans; eauto. unfold minValue_pos, minExponentPos.
Heiko Becker's avatar
Heiko Becker committed
721
722
723
724
725
726
727
728
          rewrite Q2R_inv; [ | vm_compute; congruence].
          unfold Q2R, Qnum, Qden. rewrite <- Z2R_IZR.
          vm_compute. lra. }
        { exists (Bplus 53 1024 eq_refl eq_refl binop_nan_pl64 dmode v_e1 v_e2);
            split; try auto.
          rewrite B2Q_B2R_eq; try auto.
          unfold dmode.
          eapply Binop_dist' with (delta:=eps); eauto.
729
          - cbn; lra.
Heiko Becker's avatar
Heiko Becker committed
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
          - unfold perturb, evalBinop.
            repeat rewrite B2Q_B2R_eq; try auto.
            rewrite <- round_eq. rewrite <- add_round; auto. }
    (* Subtraction *)
    + unfold evalBinop in *. unfold b64_minus.
      pose proof (Bminus_correct 53 1024 eq_refl eq_refl binop_nan_pl64 mode_NE
                                v_e1 v_e2 finite_e1 finite_e2)
        as subtraction_correct.
      rewrite cond_valid in subtraction_correct.
      destruct subtraction_correct as [add_round [finite_res _]].
      destruct case_eval as [eval_zero | eval_normal].
      (* resutl is zero *)
      * rewrite eval_zero in *.
        rewrite round_0_zero in *.
        exists (Bminus 53 1024 eq_refl eq_refl binop_nan_pl64 dmode v_e1 v_e2).
        split; try auto.
        rewrite B2Q_B2R_eq; try auto.
        unfold dmode; rewrite add_round.
        eapply Binop_dist' with (delta:=0%R); eauto.
749
750
        rewrite Rabs_R0; apply mTypeToR_pos_R.
        unfold perturb, evalBinop; cbn.
Heiko Becker's avatar
Heiko Becker committed
751
752
753
754
755
756
        repeat rewrite B2Q_B2R_eq; try auto; lra.
      * simpl in *.
        destruct (rel_error_exists
                    (fun x => negb (Zeven x))
                    (B2R 53 1024 v_e1 - B2R 53 1024 v_e2)%R)
          as [eps [eps_bounded round_eq]].
757
        { eapply Rle_trans; eauto. unfold minValue_pos, minExponentPos.
Heiko Becker's avatar
Heiko Becker committed
758
759
760
761
762
763
764
765
          rewrite Q2R_inv; [ | vm_compute; congruence].
          unfold Q2R, Qnum, Qden. rewrite <- Z2R_IZR.
          vm_compute. lra. }
        { exists (Bminus 53 1024 eq_refl eq_refl binop_nan_pl64 dmode v_e1 v_e2);
            split; try auto.
          rewrite B2Q_B2R_eq; try auto.
          unfold dmode.
          eapply Binop_dist' with (delta:=eps); eauto.
766
767
          - cbn; lra.
          - unfold perturb, evalBinop; cbn.
Heiko Becker's avatar
Heiko Becker committed
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
            repeat rewrite B2Q_B2R_eq; try auto.
            rewrite <- round_eq. rewrite <- add_round; auto. }
    (* Multiplication *)
    + unfold evalBinop in *. unfold b64_mult.
      pose proof (Bmult_correct 53 1024 eq_refl eq_refl binop_nan_pl64 mode_NE
                                v_e1 v_e2)
        as mult_correct.
      rewrite cond_valid in mult_correct.
      destruct mult_correct as [mult_round [finite_res _]].
      destruct case_eval as [eval_zero | eval_normal].
      (* resutl is zero *)
      * rewrite eval_zero in *.
        rewrite round_0_zero in *.
        exists (Bmult 53 1024 eq_refl eq_refl binop_nan_pl64 dmode v_e1 v_e2).
        split; try auto.
        rewrite B2Q_B2R_eq; try auto.
        unfold dmode; rewrite mult_round.
        eapply Binop_dist' with (delta:=0%R); eauto.
786
787
        rewrite Rabs_R0; apply mTypeToR_pos_R.
        unfold perturb, evalBinop; cbn.
Heiko Becker's avatar
Heiko Becker committed
788
789
790
791
792
793
794
795
        repeat rewrite B2Q_B2R_eq; try auto; lra.
        rewrite finite_e1, finite_e2 in finite_res.
        auto.
      * simpl in *.
        destruct (rel_error_exists
                    (fun x => negb (Zeven x))
                    (B2R 53 1024 v_e1 * B2R 53 1024 v_e2)%R)
          as [eps [eps_bounded round_eq]].
796
        { eapply Rle_trans; eauto. unfold minValue_pos, minExponentPos.
Heiko Becker's avatar
Heiko Becker committed
797
798
799
800
801
802
803
804
          rewrite Q2R_inv; [ | vm_compute; congruence].
          unfold Q2R, Qnum, Qden. rewrite <- Z2R_IZR.
          vm_compute. lra. }
        { exists (Bmult 53 1024 eq_refl eq_refl binop_nan_pl64 dmode v_e1 v_e2);
            split; try auto.
          rewrite B2Q_B2R_eq; try auto.
          unfold dmode.
          eapply Binop_dist' with (delta:=eps); eauto.
805
          - cbn; lra.
Heiko Becker's avatar
Heiko Becker committed
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
          - unfold perturb, evalBinop.
            repeat rewrite B2Q_B2R_eq; try auto.
            rewrite <- round_eq. rewrite <- mult_round; auto.
          - rewrite finite_e1, finite_e2 in finite_res; auto. }
    (* Division *)
    + unfold evalBinop in *. unfold b64_div.
      pose proof (Bdiv_correct 53 1024 eq_refl eq_refl binop_nan_pl64 mode_NE
                                v_e1 v_e2)
        as division_correct.
      rewrite cond_valid in division_correct.
      destruct division_correct as [div_round [finite_res _]].
      rewrite <- B2Q_B2R_eq; auto.
      destruct case_eval as [eval_zero | eval_normal].
      (* resutl is zero *)
      * rewrite eval_zero in *.
        rewrite round_0_zero in *.
        exists (Bdiv 53 1024 eq_refl eq_refl binop_nan_pl64 dmode v_e1 v_e2).
        split; try auto.
        rewrite B2Q_B2R_eq; try auto.
        unfold dmode; rewrite div_round.
        eapply Binop_dist' with (delta:=0%R); eauto.
827
828
        rewrite Rabs_R0; apply mTypeToR_pos_R.
        unfold perturb, evalBinop; cbn.
Heiko Becker's avatar
Heiko Becker committed
829
830
831
832
833
834
835
        repeat rewrite B2Q_B2R_eq; try auto; lra.
        rewrite finite_e1 in finite_res; auto.
      * simpl in *.
        destruct (rel_error_exists
                    (fun x => negb (Zeven x))
                    (B2R 53 1024 v_e1 / B2R 53 1024 v_e2)%R)
          as [eps [eps_bounded round_eq]].
836
        { eapply Rle_trans; eauto. unfold minValue_pos, minExponentPos.
Heiko Becker's avatar
Heiko Becker committed
837
838
839
840
841
842
843
844
          rewrite Q2R_inv; [ | vm_compute; congruence].
          unfold Q2R, Qnum, Qden. rewrite <- Z2R_IZR.
          vm_compute. lra. }
        { exists (Bdiv 53 1024 eq_refl eq_refl binop_nan_pl64 dmode v_e1 v_e2);
            split; try auto.
          rewrite B2Q_B2R_eq; try auto.
          unfold dmode.
          eapply Binop_dist' with (delta:=eps); eauto.
845
          - cbn; lra.
Heiko Becker's avatar
Heiko Becker committed
846
847
848
849
          - unfold perturb, evalBinop.
            repeat rewrite B2Q_B2R_eq; try auto.
            rewrite <- round_eq. rewrite <- div_round; auto.
          - rewrite finite_e1 in finite_res; auto. }
Nikita Zyuzin's avatar
Nikita Zyuzin committed
850
851
852
  - repeat (match goal with
            |H: _ /\ _ |- _ => destruct H
            end).
853
854
855
856
    assert (FloverMap.find (B2Qexpr e1) tMap = Some M64 /\
            FloverMap.find (B2Qexpr e2) tMap = Some M64 /\
            FloverMap.find (B2Qexpr e3) tMap = Some M64 /\
            FloverMap.find (Fma (B2Qexpr e1) (B2Qexpr e2) (B2Qexpr e3)) tMap = Some M64)
Nikita Zyuzin's avatar
Nikita Zyuzin committed
857
           as [tMap_e1 [tMap_e2 [tMap_e3 tMap_fma]]].
858
    { repeat split; apply (typing_expr_64_bit _ Gamma); simpl; auto.
Nikita Zyuzin's avatar
Nikita Zyuzin committed
859
860
861
      - intros; apply usedVars_64bit; set_tac.
      - intros; apply usedVars_64bit; set_tac.
      - intros; apply usedVars_64bit; set_tac.
862
      - rewrite Heqo, Heqo4, Heqo6, Heqo8.
Nikita Zyuzin's avatar
Nikita Zyuzin committed
863
864
865
866
867
868
869
870
        apply Is_true_eq_true; apply andb_prop_intro; split.
        + apply andb_prop_intro; split.
          * apply andb_prop_intro; split.
            ++ apply Is_true_eq_left; auto.
               apply mTypeEq_refl.
            ++ apply Is_true_eq_left; auto.
          * apply Is_true_eq_left; auto.
        + apply Is_true_eq_left; auto. }
871
    repeat destr_factorize.
Nikita Zyuzin's avatar
Nikita Zyuzin committed
872
873
    inversion Heqo; inversion Heqo0; inversion Heqo1; inversion Heqo2; subst.
    assert (m1 = M64).
874
    { eapply (typing_agrees_expr (B2Qexpr e1)); eauto. }
Nikita Zyuzin's avatar
Nikita Zyuzin committed
875
    assert (m2 = M64).
876
    { eapply (typing_agrees_expr (B2Qexpr e2)); eauto. }
Nikita Zyuzin's avatar
Nikita Zyuzin committed
877
    assert (m3 = M64).
878
    { eapply (typing_agrees_expr (B2Qexpr e3)); eauto. }
Nikita Zyuzin's avatar
Nikita Zyuzin committed
879
880
881
882
883
884
885
886
887
    subst.
    destruct (IHe1 E1 E2 E2_real Gamma tMap v1 A P fVars dVars)
      as [v_e1 [eval_float_e1 eval_rel_e1]];
      try auto; try set_tac;
        [ intros; apply usedVars_64bit ; set_tac | ].
    destruct (IHe2 E1 E2 E2_real Gamma tMap v2 A P fVars dVars)
      as [v_e2 [eval_float_e2 eval_rel_e2]];
      try auto; try set_tac;
        [ intros; apply usedVars_64bit ; set_tac | ].
888
889
890
891
    destruct (IHe3 E1 E2 E2_real Gamma tMap v3 A P fVars dVars)
      as [v_e3 [eval_float_e3 eval_rel_e3]];
      try auto; try set_tac;
        [ intros; apply usedVars_64bit ; set_tac | ].
892
    unfold optionBind in H4.
893
894
895
    rewrite eval_float_e1, eval_float_e2, eval_float_e3 in H4.
    contradiction H4.
  - inversion noDowncast_e.
Heiko Becker's avatar
Heiko Becker committed
896
897
898
899
900
901
902
903
904
905
906
Qed.

Lemma bstep_gives_IEEE (f:cmd fl64) :
  forall E1 E2 E2_real Gamma tMap vR vF A P fVars dVars outVars,
    (forall x, (toREnv E2) x = E2_real x) ->
    approxEnv E1 Gamma A fVars dVars E2_real ->
    ssa (B2Qcmd f) (NatSet.union fVars dVars) outVars ->
    typeCheckCmd (B2Qcmd f) Gamma tMap = true ->
    validIntervalboundsCmd (B2Qcmd f) A P dVars = true ->
    validErrorboundCmd (B2Qcmd f) tMap A dVars = true ->
    FPRangeValidatorCmd (B2Qcmd f) A tMap dVars = true ->
907
    bstep (toREvalCmd (toRCmd (B2Qcmd f))) E1 (toRMap Gamma) vR REAL ->
Heiko Becker's avatar
Heiko Becker committed
908
909
910
911
912
    bstep (toRCmd (B2Qcmd f)) (toREnv E2) Gamma vF M64 ->
    NatSet.Subset (NatSet.diff (freeVars (B2Qcmd f)) dVars) fVars ->
    is64BitBstep (B2Qcmd f) ->
    noDowncastFun (B2Qcmd f) ->
    bstep_valid f E2 ->
913
914
915
    dVars_range_valid dVars E1 A ->
    fVars_P_sound fVars E1 P ->
    vars_typed (NatSet.union fVars dVars) Gamma ->
Heiko Becker's avatar
Heiko Becker committed
916
917
918
      (forall v,
        NatSet.In v dVars ->
        exists vF m,
919
        (E2_real v = Some vF /\ FloverMap.find (Var Q v) tMap= Some m /\
Heiko Becker's avatar
Heiko Becker committed
920
921
922
923
924
925
926
927
928
929
        validFloatValue vF m)) ->
      (forall v, NatSet.In v (freeVars (B2Qcmd f)) -> Gamma v = Some M64) ->
      exists v,
        bstep_float f E2 = Some v /\
        bstep (toRCmd (B2Qcmd f)) (toREnv E2) Gamma (Q2R (B2Q v)) M64.
Proof.
  induction f;
    intros * envs_eq approxEnv_E1_E2_real ssa_f typeCheck_f valid_ranges_f
                     valid_roundoffs_f valid_float_ranges bstep_real bstep_float
                     freeVars_sound is64_eval nodowncast_f bstep_sound
930
                     dVars_sound fVars_defined vars_typed dVars_valid
Heiko Becker's avatar
Heiko Becker committed
931
                     freeVars_typed;
932
    cbn in *; Flover_compute_asm; try congruence; type_conv; subst;
933
      unfold Ltacs.optionBind;
934
      inversion bstep_float; inversion bstep_real;
Heiko Becker's avatar
Heiko Becker committed
935
936
937
938
      inversion ssa_f; subst; simpl in *;
        repeat (match goal with
                | H: _ = true |- _ => andb_to_prop H
                end).
939
940
  - assert (FloverMap.find (B2Qexpr e) tMap= Some M64).
    { eapply typing_expr_64_bit; try eauto.
Heiko Becker's avatar
Heiko Becker committed
941
942
943
      simpl in *; destruct nodowncast_f; auto.
      destruct is64_eval; auto.
      intros; apply freeVars_typed.
944
      set_tac.
Heiko Becker's avatar
Heiko Becker committed
945
946
947
948
      split; [ set_tac | ].
      hnf; intros; subst.
      apply H26.
      apply (H25 n H).  }
949
    assert (m1 = M64).
950
    { eapply typing_agrees_expr; eauto. }
Heiko Becker's avatar
Heiko Becker committed
951
    subst.
952
953
    assert (exists v_e, eval_expr_float e E2 = Some v_e /\
                   eval_expr (toREnv E2) Gamma (toRExp (B2Qexpr e)) (Q2R (B2Q v_e)) M64)
Heiko Becker's avatar
Heiko Becker committed
954
           as eval_float_e.
955
    { eapply eval_expr_gives_IEEE; try eauto.
Heiko Becker's avatar
Heiko Becker committed
956
957
958
959
960
961
962
963
964
965
966
      - hnf; intros. rewrite NatSet.diff_spec in H0.
        destruct H0.
        specialize (H25 a H0). rewrite NatSet.union_spec in H25.
        destruct H25; try congruence; auto.
      - destruct is64_eval; auto.
      - destruct nodowncast_f; auto.
      - destruct bstep_sound; auto.
      - intros. apply freeVars_typed.
        rewrite NatSet.remove_spec, NatSet.union_spec.
        split; try auto.
        hnf; intros; subst.
967
968
        specialize (H25 n H0).
        set_tac.  apply H26; set_tac. }
Heiko Becker's avatar
Heiko Becker committed
969
    destruct eval_float_e as [v_e [eval_float_e eval_rel_e]].
970
    assert (forall v m, eval_expr E2_real Gamma (toRExp (B2Qexpr e)) v m ->
971
                   Rabs (v0 - v) <= Q2R e2)%R
Heiko Becker's avatar
Heiko Becker committed
972
973
974
975
      as err_e_valid.
    { eapply validErrorbound_sound; try eauto.
      - hnf; intros. rewrite NatSet.diff_spec in H0.
        destruct H0. specialize (H25 a H0). rewrite NatSet.union_spec in H25.
976
977
        destruct H25; try auto; congruence. }
    assert (Rabs (v0 - (Q2R (B2Q v_e))) <= Q2R e2)%R.
Heiko Becker's avatar
Heiko Becker committed
978
979
980
    { eapply err_e_valid. eapply eval_eq_env; eauto. }
    (* Now construct a new evaluation according to our big-step semantics
       using lemma validErrorboundCmd_gives_eval *)
981
982
    (* destruct (A (getRetExp (B2Qcmd f))) as [iv_f err_f] eqn:A_f. *)
    (* destruct iv_f as [ivlo_f ivhi_f]. *)
Heiko Becker's avatar
Heiko Becker committed
983
984
985
986
    edestruct (validIntervalboundsCmd_sound) as [iv_ret [err_ret [v_ret
                                                                    [map_ret
                                                                       [eval_ret bound_ret]]]]];
      eauto.
987
    { cbn. Flover_compute.
Heiko Becker's avatar
Heiko Becker committed
988
      rewrite L0, R4, R3, R2. auto. }
Heiko Becker's avatar
Heiko Becker committed
989
    assert (exists vF m, bstep (toRCmd (B2Qcmd f)) (updEnv n (Q2R (B2Q v_e)) E2_real) (updDefVars n M64 Gamma) vF m).
Heiko Becker's avatar
Heiko Becker committed
990
991
992
993
    { eapply validErrorboundCmd_gives_eval with (E1 := updEnv n v0 E1)
                                                  (elo:=fst(iv_ret))
                                                  (ehi:=snd(iv_ret))
                                                  (err:= err_ret); eauto.
Heiko Becker's avatar
Heiko Becker committed
994
995
996
      - eapply approxUpdBound; eauto.
        rewrite Qeq_bool_iff in R1.
        eapply Rle_trans; eauto.
997
998
        canonize_hyps. rewrite <- R1.
        inversion Heqo0; subst; lra.
Heiko Becker's avatar
Heiko Becker committed
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
      - eapply ssa_equal_set; eauto.
        hnf; split; intros.
        + rewrite NatSet.add_spec, NatSet.union_spec in *.
          rewrite NatSet.add_spec in H1; destruct H1; auto.
          destruct H1; auto.
        + rewrite NatSet.add_spec in H1;
            rewrite NatSet.union_spec, NatSet.add_spec in *;
            destruct H1; auto. destruct H1; auto.
      - hnf; intros. rewrite NatSet.diff_spec in H1.
        destruct H1. apply freeVars_sound.
        rewrite NatSet.diff_spec, NatSet.remove_spec, NatSet.union_spec.
        split; try auto. split; try auto.
        hnf; intros; subst. apply H2. rewrite NatSet.add_spec. auto.
        rewrite NatSet.add_spec in H2. hnf; intros; apply H2; auto.
1013
      - eapply (swap_Gamma_bstep (Gamma1:= updDefVars n REAL (toRMap Gamma)));
Heiko Becker's avatar
Heiko Becker committed
1014
1015
1016
          eauto.
        intros; unfold updDefVars, toRMap.
        destruct (n0 =? n); auto.
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
      - unfold dVars_range_valid in *. intros. unfold updEnv. set_tac.
        destruct H1; subst.
        + exists v0, (q1, q2), e1; split; try eauto.
          * rewrite Nat.eqb_refl; auto.
          * split; try auto.
            edestruct validIntervalbounds_sound
              as [iv_e [err_e [v_e' [map_e [? ?]]]]]; eauto.
            { set_tac; split; try auto. split; try auto.
              hnf; intros. eapply H26. subst; set_tac. }
            simpl. destr_factorize; simpl in *.
            canonize_hyps. rewrite <- R4, <- R3.
            rewrite <- (meps_0_deterministic _ H17 H1) in H2; auto.
        + destruct H1.
          rewrite <- Nat.eqb_neq in H1.
          rewrite H1.
Heiko Becker's avatar
Heiko Becker committed
1032
          apply dVars_sound; auto.
Heiko Becker's avatar
Heiko Becker committed
1033
      - unfold fVars_P_sound; intros; unfold updEnv.
Heiko Becker's avatar
Heiko Becker committed
1034
1035
1036
        destruct (v1 =? n) eqn:?.
        + rewrite Nat.eqb_eq in Heqb; subst; exfalso.
          set_tac. apply H26; rewrite NatSet.union_spec; auto.
Heiko Becker's avatar
Heiko Becker committed
1037
1038
1039
        + apply fVars_defined; auto.
      - unfold IntervalValidation.vars_typed. intros.
        unfold updDefVars. destruct (v1 =? n) eqn:?.
Heiko Becker's avatar
Heiko Becker committed
1040
1041
1042
1043
        + exists M64; auto.
        + apply vars_typed.
          rewrite Nat.eqb_neq in Heqb.
          rewrite NatSet.union_spec, NatSet.add_spec in H1.
Heiko Becker's avatar
Heiko Becker committed
1044
1045
1046
1047
          rewrite NatSet.union_spec.
          destruct H1 as [HA |[HB | HC]]; try auto; congruence.
      - destruct iv_ret; auto.
    }
1048
    unfold optionBind. rewrite eval_float_e.
1049
    assert (FloverMap.find (getRetExp (B2Qcmd f)) tMap= Some M64).
Heiko Becker's avatar
Heiko Becker committed
1050
    { eapply typingSoundnessCmd; eauto. }
Heiko Becker's avatar
Heiko Becker committed
1051
1052
    destruct H1 as [vF_new [m_f bstep_float_new]].
    assert (m_f = M64).
Heiko Becker's avatar
Heiko Becker committed
1053
    { eapply typing_agrees_cmd; eauto. }
Heiko Becker's avatar
Heiko Becker committed
1054
1055
1056
1057
1058
1059
    subst.
    destruct (IHf (updEnv n v0 E1) (updFlEnv n v_e E2)
                  (updEnv n (Q2R (B2Q v_e)) E2_real) (updDefVars n M64 Gamma) tMap
                  vR vF_new A P fVars (NatSet.add n dVars) outVars); try eauto.
    + intros. unfold toREnv, updFlEnv, updEnv.
      destruct (x =? n); auto. rewrite <- envs_eq. unfold toREnv; auto.
Heiko Becker's avatar
Heiko Becker committed
1060
    + eapply approxUpdBound; eauto.
Heiko Becker's avatar
Heiko Becker committed
1061
      eapply Rle_trans; eauto.
Heiko Becker's avatar
Heiko Becker committed
1062
1063
1064
      canonize_hyps.
      inversion Heqo0; subst.
      lra.
Heiko Becker's avatar
Heiko Becker committed
1065
1066
1067
1068
1069
1070
1071
1072
    + eapply ssa_equal_set; eauto.
      hnf; split; intros.
      * rewrite NatSet.add_spec, NatSet.union_spec in *.
        rewrite NatSet.add_spec in H1; destruct H1; auto.
        destruct H1; auto.
      * rewrite NatSet.add_spec in H1;
          rewrite NatSet.union_spec, NatSet.add_spec in *;
          destruct H1; auto. destruct H1; auto.
1073
    + eapply (swap_Gamma_bstep (Gamma1:= updDefVars n REAL (toRMap Gamma)));
Heiko Becker's avatar
Heiko Becker committed
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
        eauto.
      intros; unfold updDefVars, toRMap.
      destruct (n0 =? n); auto.
    + eapply (bstep_eq_env (E1 := updEnv n (Q2R (B2Q v_e)) E2_real)); eauto.
      intros x; unfold updEnv, updFlEnv, toREnv.
      destruct (x =? n); try auto.
      rewrite <- envs_eq. auto.
    + hnf; intros. rewrite NatSet.diff_spec in *.
      destruct H1. apply freeVars_sound.
      rewrite NatSet.diff_spec, NatSet.remove_spec, NatSet.union_spec.
      split; try auto. split; try auto.
      hnf; intros; subst. apply H3. rewrite NatSet.add_spec. auto.
      rewrite NatSet.add_spec in H3. hnf; intros; apply H3; auto.
    + destruct is64_eval as [HA [HB HC]]; auto.
    + destruct nodowncast_f as [HA HB]; auto.
    + destruct bstep_sound as [eval_sound bstep_sound].