Skip to content

GitLab

Commit 3d6185b5 authored by Heiko Becker's avatar Heiko Becker
Browse files
Options

Add fixed-point precision to HOL4, fix minor bug in configure script

parent 2dd19d8d
Hide whitespace changes
Inline Side-by-side
Showing with 782 additions and 664 deletions
hol4/CertificateCheckerScript.sml
View file @ 3d6185b5
...@@ -44,7 +44,7 @@ val Certificate_checking_is_sound = store_thm ("Certificate_checking_is_sound", ...@@ -44,7 +44,7 @@ val Certificate_checking_is_sound = store_thm ("Certificate_checking_is_sound",
CertificateChecker e A P defVars ==> CertificateChecker e A P defVars ==>
?iv err vR vF m. ?iv err vR vF m.
FloverMapTree_find e A = SOME (iv,err) /\ FloverMapTree_find e A = SOME (iv,err) /\
eval_exp E1 (toRMap defVars) (toREval e) vR M0 /\ eval_exp E1 (toRMap defVars) (toREval e) vR REAL /\
eval_exp E2 defVars e vF m /\ eval_exp E2 defVars e vF m /\
(!vF m. (!vF m.
eval_exp E2 defVars e vF m ==> eval_exp E2 defVars e vF m ==>
...@@ -99,7 +99,7 @@ val CertificateCmd_checking_is_sound = store_thm ("CertificateCmd_checking_is_so ...@@ -99,7 +99,7 @@ val CertificateCmd_checking_is_sound = store_thm ("CertificateCmd_checking_is_so
CertificateCheckerCmd f A P defVars ==> CertificateCheckerCmd f A P defVars ==>
?iv err vR vF m. ?iv err vR vF m.
FloverMapTree_find (getRetExp f) A = SOME (iv, err) /\ FloverMapTree_find (getRetExp f) A = SOME (iv, err) /\
bstep (toREvalCmd f) E1 (toRMap defVars) vR M0 /\ bstep (toREvalCmd f) E1 (toRMap defVars) vR REAL /\
bstep f E2 defVars vF m /\ bstep f E2 defVars vF m /\
(!vF m. bstep f E2 defVars vF m ==> abs (vR - vF) <= err)``, (!vF m. bstep f E2 defVars vF m ==> abs (vR - vF) <= err)``,
simp [CertificateCheckerCmd_def] simp [CertificateCheckerCmd_def]
......
hol4/CommandsScript.sml
View file @ 3d6185b5
...@@ -20,7 +20,7 @@ val _ = Datatype ` ...@@ -20,7 +20,7 @@ val _ = Datatype `
val toREvalCmd_def = Define ` val toREvalCmd_def = Define `
toREvalCmd (f:real cmd) : real cmd = toREvalCmd (f:real cmd) : real cmd =
case f of case f of
| Let m x e g => Let M0 x (toREval e) (toREvalCmd g) | Let m x e g => Let REAL x (toREval e) (toREvalCmd g)
| Ret e => Ret (toREval e)`; | Ret e => Ret (toREval e)`;
(** (**
......
hol4/EnvironmentsScript.sml
View file @ 3d6185b5
...@@ -12,7 +12,7 @@ val (approxEnv_rules, approxEnv_ind, approxEnv_cases) = Hol_reln ` ...@@ -12,7 +12,7 @@ val (approxEnv_rules, approxEnv_ind, approxEnv_cases) = Hol_reln `
(!(E1:env) (E2:env) (defVars: num -> mType option) (A:analysisResult) (fVars:num_set) (dVars:num_set) v1 v2 x. (!(E1:env) (E2:env) (defVars: num -> mType option) (A:analysisResult) (fVars:num_set) (dVars:num_set) v1 v2 x.
approxEnv E1 defVars A fVars dVars E2 /\ approxEnv E1 defVars A fVars dVars E2 /\
(defVars x = SOME m) /\ (defVars x = SOME m) /\
(abs (v1 - v2) <= abs v1 * (mTypeToR m)) /\ (abs (v1 - v2) <= computeError v1 m) /\
(lookup x (union fVars dVars) = NONE) ==> (lookup x (union fVars dVars) = NONE) ==>
approxEnv (updEnv x v1 E1) (updDefVars x m defVars) A (insert x () fVars) dVars (updEnv x v2 E2)) /\ approxEnv (updEnv x v1 E1) (updDefVars x m defVars) A (insert x () fVars) dVars (updEnv x v2 E2)) /\
(!(E1:env) (E2:env) (defVars: num -> mType option) (A:analysisResult) (!(E1:env) (E2:env) (defVars: num -> mType option) (A:analysisResult)
...@@ -58,7 +58,7 @@ val approxEnv_fVar_bounded = store_thm ( ...@@ -58,7 +58,7 @@ val approxEnv_fVar_bounded = store_thm (
E2 x = SOME v2 /\ E2 x = SOME v2 /\
x IN (domain fVars) /\ x IN (domain fVars) /\
Gamma x = SOME m ==> Gamma x = SOME m ==>
abs (v - v2) <= (abs v) * (mTypeToR m)``, abs (v - v2) <= computeError v m``,
rpt strip_tac rpt strip_tac
\\ qspec_then \\ qspec_then
`\E1 Gamma absenv fVars dVars E2. `\E1 Gamma absenv fVars dVars E2.
...@@ -67,7 +67,7 @@ val approxEnv_fVar_bounded = store_thm ( ...@@ -67,7 +67,7 @@ val approxEnv_fVar_bounded = store_thm (
E2 x = SOME v2 /\ E2 x = SOME v2 /\
x IN (domain fVars) /\ x IN (domain fVars) /\
Gamma x = SOME m ==> Gamma x = SOME m ==>
abs (v - v2) <= (abs v) * (mTypeToR m)` abs (v - v2) <= computeError v m`
(fn thm => irule (SIMP_RULE std_ss [] thm)) (fn thm => irule (SIMP_RULE std_ss [] thm))
approxEnv_ind approxEnv_ind
\\ rpt strip_tac \\ rpt strip_tac
......
hol4/ErrorBoundsScript.sml
View file @ 3d6185b5
...@@ -13,263 +13,370 @@ val _ = new_theory "ErrorBounds"; ...@@ -13,263 +13,370 @@ val _ = new_theory "ErrorBounds";
val _ = Parse.hide "delta"; (* so that it can be used as a variable *) val _ = Parse.hide "delta"; (* so that it can be used as a variable *)
val _ = temp_overload_on("abs",``real$abs``); val _ = temp_overload_on("abs",``real$abs``);
val triangle_trans = store_thm (
"triangle_trans",
``!a b c.
abs (a + b) <= abs a + abs b /\
abs a + abs b <= c ==>
abs (a + b) <= c``,
rpt strip_tac
\\ REAL_ASM_ARITH_TAC);
val triangle_tac =
irule triangle_trans \\ fs[REAL_ABS_TRIANGLE];
val const_abs_err_bounded = store_thm ("const_abs_err_bounded", val const_abs_err_bounded = store_thm ("const_abs_err_bounded",
``!(n:real) (nR:real) (nF:real) (E1 E2:env) (m:mType) (defVars: num -> mType option). ``!(n:real) (nR:real) (nF:real) (E1 E2:env) (m:mType) (defVars: num -> mType option).
eval_exp E1 (toRMap defVars) (Const M0 n) nR M0 /\ eval_exp E1 (toRMap defVars) (Const REAL n) nR REAL /\
eval_exp E2 defVars (Const m n) nF m ==> eval_exp E2 defVars (Const m n) nF m ==>
abs (nR - nF) <= abs n * (mTypeToR m)``, abs (nR - nF) <= computeError n m``,
rpt strip_tac rpt strip_tac
\\ fs[eval_exp_cases] \\ fs[eval_exp_cases]
\\ `perturb n delta = n` by (irule delta_0_deterministic \\ fs[mTypeToR_def]) \\ Cases_on `m` \\ fs[perturb_def, Rabs_err_simpl, REAL_ABS_MUL, computeError_def]
\\ simp[perturb_def, Rabs_err_simpl, REAL_ABS_MUL] >- (irule REAL_LE_LMUL_IMP \\ REAL_ASM_ARITH_TAC)
\\ irule REAL_LE_LMUL_IMP \\ REAL_ASM_ARITH_TAC); >- (irule REAL_LE_LMUL_IMP \\ REAL_ASM_ARITH_TAC)
>- (irule REAL_LE_LMUL_IMP \\ REAL_ASM_ARITH_TAC)
\\ REAL_ASM_ARITH_TAC);
val float_add_tac =
(`e1R + e2R + -((e1F + e2F) * (1 + deltaF)) =
(e1R + - e1F) + ((e2R + - e2F) + - (e1F + e2F) * deltaF)`
by REAL_ASM_ARITH_TAC
\\ simp []
\\ triangle_tac
\\ once_rewrite_tac [GSYM REAL_ADD_ASSOC]
\\ match_mp_tac REAL_LE_ADD2 \\ fs[GSYM real_sub]
\\ once_rewrite_tac [REAL_ADD_ASSOC]
\\ triangle_tac
\\ match_mp_tac REAL_LE_ADD2 \\ fs[GSYM real_sub]
\\ once_rewrite_tac [REAL_ABS_MUL]
\\ simp[computeError_def]
\\ match_mp_tac REAL_LE_MUL2
\\ fs [REAL_ABS_POS, ABS_NEG]);
val add_abs_err_bounded = store_thm ("add_abs_err_bounded", val add_abs_err_bounded = store_thm ("add_abs_err_bounded",
``!(e1:real exp) (e1R:real) (e1F:real) (e2:real exp) (e2R:real) (e2F:real) (err1:real) (err2:real) ``!(e1:real exp) (e1R:real) (e1F:real) (e2:real exp) (e2R:real) (e2F:real)
(vR:real) (vF:real) (E1 E2:env) (m m1 m2:mType) (defVars: num -> mType option). (err1:real) (err2:real) (vR:real) (vF:real) (E1 E2:env) (m m1 m2:mType)
eval_exp E1 (toRMap defVars) (toREval e1) e1R M0 /\ (defVars: num -> mType option).
eval_exp E1 (toRMap defVars) (toREval e1) e1R REAL /\
eval_exp E2 defVars e1 e1F m1 /\ eval_exp E2 defVars e1 e1F m1 /\
eval_exp E1 (toRMap defVars) (toREval e2) e2R M0 /\ eval_exp E1 (toRMap defVars) (toREval e2) e2R REAL /\
eval_exp E2 defVars e2 e2F m2 /\ eval_exp E2 defVars e2 e2F m2 /\
eval_exp E1 (toRMap defVars) (toREval (Binop Plus e1 e2)) vR M0 /\ eval_exp E1 (toRMap defVars) (toREval (Binop Plus e1 e2)) vR REAL /\
eval_exp (updEnv 2 e2F (updEnv 1 e1F emptyEnv)) (updDefVars 2 m2 (updDefVars 1 m1 defVars)) (Binop Plus (Var 1) (Var 2)) vF m /\ eval_exp (updEnv 2 e2F (updEnv 1 e1F emptyEnv))
(updDefVars 2 m2 (updDefVars 1 m1 defVars))
(Binop Plus (Var 1) (Var 2)) vF m /\
abs (e1R - e1F) <= err1 /\ abs (e1R - e1F) <= err1 /\
abs (e2R - e2F) <= err2 ==> abs (e2R - e2F) <= err2 ==>
abs (vR - vF) <= err1 + err2 + (abs (e1F + e2F) * (mTypeToR m))``, abs (vR - vF) <= err1 + err2 + (computeError (e1F + e2F) m)``,
rpt strip_tac rpt strip_tac \\ fs[toREval_def]
\\ qpat_x_assum `eval_exp E1 _ (toREval (Binop Plus e1 e2)) _ _` (fn thm => assume_tac (ONCE_REWRITE_RULE [toREval_def] thm))
\\ fs []
\\ inversion `eval_exp E1 _ (Binop Plus _ _) _ _` eval_exp_cases \\ inversion `eval_exp E1 _ (Binop Plus _ _) _ _` eval_exp_cases
\\ rename1 `vR = perturb (evalBinop Plus v1R v2R) deltaR` \\ rename1 `vR = perturb (evalBinop Plus v1R v2R) (join m1R m2R) deltaR`
\\ inversion `eval_exp _ _ (Binop Plus (Var 1) (Var 2)) _ _` eval_exp_cases \\ inversion `eval_exp _ _ (Binop Plus (Var 1) (Var 2)) _ _` eval_exp_cases
\\ rename1 `vF = perturb (evalBinop Plus v1F v2F) deltaF` \\ rename1 `vF = perturb (evalBinop Plus v1F v2F) (join m1F m2F) deltaF`
\\ `(m1' = M0) /\ (m2' = M0)` by (conj_tac \\ irule toRMap_eval_M0 \\ asm_exists_tac \\ fs[]) \\ fs [] \\ `(m1R = REAL) /\ (m2R = REAL)`
\\ rpt (qpat_x_assum `M0 = _` (fn thm => fs [GSYM thm])) by (conj_tac \\ irule toRMap_eval_REAL \\ asm_exists_tac \\ fs[]) \\ fs []
\\ `perturb (evalBinop Plus v1R v2R) deltaR = evalBinop Plus v1R v2R` by (match_mp_tac delta_M0_deterministic \\ fs[]) \\ rpt (qpat_x_assum `REAL = _` (fn thm => fs [GSYM thm]))
\\ `vR = evalBinop Plus v1R v2R` by simp[] \\ rveq \\ fs[perturb_def]
\\ `v1R = e1R` by metis_tac [meps_0_deterministic] \\ `v1R = e1R` by metis_tac [meps_0_deterministic]
\\ `v2R = e2R` by metis_tac [meps_0_deterministic] \\ `v2R = e2R` by metis_tac [meps_0_deterministic]
\\ rveq \\ fs[evalBinop_def, perturb_def] \\ rveq
\\ rpt (inversion `eval_exp (updEnv 2 e2F (updEnv 1 e1F emptyEnv)) _ _ _ _` eval_exp_cases) \\ rpt (inversion `eval_exp (updEnv 2 e2F (updEnv 1 e1F emptyEnv)) _ _ _ _` eval_exp_cases)
\\ fs [updEnv_def] \\ rveq \\ fs [updEnv_def] \\ rveq
\\ fs [updDefVars_def] \\ rveq
\\ once_rewrite_tac[real_sub] \\ once_rewrite_tac[real_sub]
\\ `e1R + e2R + -((e1F + e2F) * (1 + deltaF)) = (e1R + - e1F) + ((e2R + - e2F) + - (e1F + e2F) * deltaF)` by REAL_ASM_ARITH_TAC \\ Cases_on `join m1 m2` \\ fs[perturb_def, evalBinop_def]
\\ simp [] >- (`e1R + e2R + -(e1F + e2F) = (e1R + - e1F) + ((e2R + - e2F))`
(** Currently the best way I could find to get around skolem variables, as used in Coq **) by REAL_ASM_ARITH_TAC
\\ qspecl_then [`abs (e1R + - e1F) + abs ((e2R + - e2F) + - (e1F + e2F) * deltaF)`] match_mp_tac real_le_trans2 \\ simp[computeError_def]
\\ fs [REAL_ABS_TRIANGLE] \\ irule REAL_LE_TRANS
\\ once_rewrite_tac [GSYM REAL_ADD_ASSOC] \\ qexists_tac `abs (e1R + - e1F) + abs (e2R + - e2F)`
\\ match_mp_tac REAL_LE_ADD2 \\ fs[GSYM real_sub] \\ fs[REAL_ABS_TRIANGLE]
\\ once_rewrite_tac [REAL_ADD_ASSOC] \\ REAL_ASM_ARITH_TAC)
\\ qspecl_then [`abs (e2R + - e2F) + abs (-(e1F + e2F) * deltaF)`] match_mp_tac real_le_trans2 >- (float_add_tac)
\\ fs [REAL_ABS_TRIANGLE] >- (float_add_tac)
\\ match_mp_tac REAL_LE_ADD2 \\ fs[GSYM real_sub] >- (float_add_tac)
\\ once_rewrite_tac [REAL_ABS_MUL] \\ simp[computeError_def]
\\ match_mp_tac REAL_LE_MUL2 \\ `e1R + e2R + - (e1F + e2F + deltaF) = (e1R + - e1F) + (e2R + - e2F + - deltaF)`
\\ fs [REAL_ABS_POS, ABS_NEG]); by (REAL_ASM_ARITH_TAC)
\\ simp[]
\\ triangle_tac
\\ rewrite_tac [GSYM REAL_ADD_ASSOC]
\\ irule REAL_LE_ADD2 \\ fs[real_sub]
\\ rewrite_tac [REAL_ADD_ASSOC]
\\ triangle_tac
\\ irule REAL_LE_ADD2 \\ fs[real_sub]
\\ REAL_ASM_ARITH_TAC);
val float_sub_tac =
(`e1R + -e2R + -((e1F + -e2F) * (1 + deltaF)) =
(e1R + - e1F) + ((- e2R + e2F) + - (e1F + - e2F) * deltaF)`
by REAL_ASM_ARITH_TAC
\\ simp []
\\ triangle_tac
\\ once_rewrite_tac [GSYM REAL_ADD_ASSOC]
\\ match_mp_tac REAL_LE_ADD2 \\ fs[GSYM real_sub]
\\ once_rewrite_tac [REAL_ADD_ASSOC]
\\ triangle_tac
\\ match_mp_tac REAL_LE_ADD2 \\ conj_tac
>- REAL_ASM_ARITH_TAC
\\ once_rewrite_tac [REAL_ABS_MUL, ABS_NEG]
\\ match_mp_tac REAL_LE_MUL2
\\ fs [REAL_ABS_POS, ABS_NEG]);
val subtract_abs_err_bounded = store_thm ("subtract_abs_err_bounded", val subtract_abs_err_bounded = store_thm ("subtract_abs_err_bounded",
``!(e1:real exp) (e1R:real) (e1F:real) (e2:real exp) (e2R:real) (e2F:real) (err1:real) (err2:real) ``!(e1:real exp) (e1R:real) (e1F:real) (e2:real exp) (e2R:real) (e2F:real) (err1:real) (err2:real)
(vR:real) (vF:real) (E1 E2:env) (m m1 m2:mType) (defVars: num -> mType option). (vR:real) (vF:real) (E1 E2:env) (m m1 m2:mType) (defVars: num -> mType option).
eval_exp E1 (toRMap defVars) (toREval e1) e1R M0 /\ eval_exp E1 (toRMap defVars) (toREval e1) e1R REAL /\
eval_exp E2 defVars e1 e1F m1 /\ eval_exp E2 defVars e1 e1F m1 /\
eval_exp E1 (toRMap defVars) (toREval e2) e2R M0 /\ eval_exp E1 (toRMap defVars) (toREval e2) e2R REAL /\
eval_exp E2 defVars e2 e2F m2 /\ eval_exp E2 defVars e2 e2F m2 /\
eval_exp E1 (toRMap defVars) (toREval (Binop Sub e1 e2)) vR M0 /\ eval_exp E1 (toRMap defVars) (toREval (Binop Sub e1 e2)) vR REAL /\
eval_exp (updEnv 2 e2F (updEnv 1 e1F emptyEnv)) (updDefVars 2 m2 (updDefVars 1 m1 defVars)) (Binop Sub (Var 1) (Var 2)) vF m /\ eval_exp (updEnv 2 e2F (updEnv 1 e1F emptyEnv))
(updDefVars 2 m2 (updDefVars 1 m1 defVars))
(Binop Sub (Var 1) (Var 2)) vF m /\
abs (e1R - e1F) <= err1 /\ abs (e1R - e1F) <= err1 /\
abs (e2R - e2F) <= err2 ==> abs (e2R - e2F) <= err2 ==>
abs (vR - vF) <= err1 + err2 + (abs (e1F - e2F) * (mTypeToR m))``, abs (vR - vF) <= err1 + err2 + computeError (e1F - e2F) m``,
rpt strip_tac rpt strip_tac
\\ qpat_x_assum `eval_exp E1 _ (toREval (Binop Sub e1 e2)) _ _` (fn thm => assume_tac (ONCE_REWRITE_RULE [toREval_def] thm)) \\ fs[toREval_def]
\\ fs []
\\ inversion `eval_exp E1 _ (Binop Sub _ _) _ _` eval_exp_cases \\ inversion `eval_exp E1 _ (Binop Sub _ _) _ _` eval_exp_cases
\\ rename1 `vR = perturb (evalBinop Sub v1R v2R) deltaR` \\ rename1 `vR = perturb (evalBinop Sub v1R v2R) (join m1R m2R) deltaR`
\\ inversion `eval_exp _ _ (Binop Sub (Var 1) (Var 2)) _ _` eval_exp_cases \\ inversion `eval_exp _ _ (Binop Sub (Var 1) (Var 2)) _ _` eval_exp_cases
\\ rename1 `vF = perturb (evalBinop Sub v1F v2F) deltaF` \\ rename1 `vF = perturb (evalBinop Sub v1F v2F) (join m1F m2F) deltaF`
\\ `(m1' = M0) /\ (m2' = M0)` by (conj_tac \\ irule toRMap_eval_M0\\ asm_exists_tac \\ fs[]) \\ fs [] \\ `(m1R = REAL) /\ (m2R = REAL)`
\\ rpt (qpat_x_assum `M0 = _` (fn thm => fs [GSYM thm])) by (conj_tac \\ irule toRMap_eval_REAL\\ asm_exists_tac \\ fs[])
\\ `perturb (evalBinop Sub v1R v2R) deltaR = evalBinop Sub v1R v2R` by (match_mp_tac delta_M0_deterministic \\ fs[]) \\ rveq
\\ `vR = evalBinop Sub v1R v2R` by simp[]
\\ `v1R = e1R` by metis_tac[meps_0_deterministic] \\ `v1R = e1R` by metis_tac[meps_0_deterministic]
\\ `v2R = e2R` by metis_tac[meps_0_deterministic] \\ `v2R = e2R` by metis_tac[meps_0_deterministic]
\\ fs[evalBinop_def, perturb_def] \\ rveq
\\ rpt (inversion `eval_exp (updEnv 2 e2F (updEnv 1 e1F emptyEnv)) _ _ _ _` eval_exp_cases) \\ rpt (inversion `eval_exp (updEnv 2 e2F (updEnv 1 e1F emptyEnv)) _ _ _ _`
eval_exp_cases)
\\ fs [updEnv_def] \\ rveq \\ fs [updEnv_def] \\ rveq
\\ fs [updDefVars_def] \\ rveq \\ Cases_on `join m1 m2`
\\ fs[perturb_def, join_def, evalBinop_def, computeError_def]
\\ rewrite_tac[real_sub] \\ rewrite_tac[real_sub]
\\ `e1R + -e2R + -((e1F + -e2F) * (1 + deltaF)) = (e1R + - e1F) + ((- e2R + e2F) + - (e1F + - e2F) * deltaF)` >- (`e1R - e2R + - (e1F - e2F) = e1R + - e1F + (- e2R + e2F)`
by REAL_ASM_ARITH_TAC by REAL_ASM_ARITH_TAC
\\ simp [] \\ simp[]
(** Currently the best way I could find to get around skolem variables, as used in Coq **) \\ irule REAL_LE_TRANS
\\ qspecl_then [`abs (e1R + - e1F) + abs ((- e2R + e2F) + - (e1F + - e2F) * deltaF)`] match_mp_tac real_le_trans2 \\ qexists_tac `abs (e1R + - e1F) + abs (-e2R + e2F)`
\\ fs [REAL_ABS_TRIANGLE] \\ fs[REAL_ABS_TRIANGLE]
\\ once_rewrite_tac [GSYM REAL_ADD_ASSOC] \\ REAL_ASM_ARITH_TAC)
\\ match_mp_tac REAL_LE_ADD2 \\ fs[GSYM real_sub] >- (float_sub_tac)
\\ once_rewrite_tac [REAL_ADD_ASSOC] >- (float_sub_tac)
\\ qspecl_then [`abs (- e2R + e2F) + abs (-(e1F - e2F) * deltaF)`] match_mp_tac real_le_trans2 >- (float_sub_tac)
\\ fs [REAL_ABS_TRIANGLE] \\ `e1R + - e2R + - (e1F + - e2F + deltaF) = (e1R + - e1F) + (- e2R + e2F + - deltaF)`
\\ match_mp_tac REAL_LE_ADD2 by (REAL_ASM_ARITH_TAC)
\\ simp[]
\\ triangle_tac
\\ rewrite_tac [GSYM REAL_ADD_ASSOC]
\\ irule REAL_LE_ADD2 \\ fs[real_sub]
\\ rewrite_tac [REAL_ADD_ASSOC]
\\ triangle_tac
\\ irule REAL_LE_ADD2 \\ fs[real_sub]
\\ REAL_ASM_ARITH_TAC);
val float_mul_tac =
(`e1R * e2R + -(e1F * e2F * (1 + deltaF)) =
(e1R * e2R + - (e1F * e2F)) + - (e1F * e2F * deltaF)`
by REAL_ASM_ARITH_TAC
\\ simp[]
\\ irule REAL_LE_TRANS
\\ qexists_tac `abs (e1R * e2R + - (e1F * e2F)) + abs(- (e1F * e2F * deltaF))`
\\ conj_tac \\ conj_tac
>- (`-e2R + e2F = e2F - e2R` by REAL_ASM_ARITH_TAC \\ simp[] >- (REAL_ASM_ARITH_TAC)
\\ once_rewrite_tac [ABS_SUB] \\ fs[]) \\ irule REAL_LE_ADD2 \\ fs[ABS_NEG, computeError_def]
>- (once_rewrite_tac [REAL_ABS_MUL] \\ once_rewrite_tac[REAL_ABS_MUL]
\\ match_mp_tac REAL_LE_MUL2 \\ match_mp_tac REAL_LE_MUL2 \\ fs[REAL_ABS_POS]
\\ fs [REAL_ABS_POS, ABS_NEG])); \\ once_rewrite_tac[GSYM REAL_NEG_LMUL, REAL_ABS_MUL] \\ fs[]);
val mult_abs_err_bounded = store_thm ("mult_abs_err_bounded", val mult_abs_err_bounded = store_thm ("mult_abs_err_bounded",
``!(e1:real exp) (e1R:real) (e1F:real) (e2:real exp) (e2R:real) (e2F:real) (err1:real) (err2:real) ``!(e1:real exp) (e1R:real) (e1F:real) (e2:real exp) (e2R:real) (e2F:real) (err1:real) (err2:real)
(vR:real) (vF:real) (E1 E2 :env) (m m1 m2:mType) (defVars: num -> mType option). (vR:real) (vF:real) (E1 E2 :env) (m m1 m2:mType) (defVars: num -> mType option).
eval_exp E1 (toRMap defVars) (toREval e1) e1R M0 /\ eval_exp E1 (toRMap defVars) (toREval e1) e1R REAL /\
eval_exp E2 defVars e1 e1F m1 /\ eval_exp E2 defVars e1 e1F m1 /\
eval_exp E1 (toRMap defVars) (toREval e2) e2R M0 /\ eval_exp E1 (toRMap defVars) (toREval e2) e2R REAL /\
eval_exp E2 defVars e2 e2F m2 /\ eval_exp E2 defVars e2 e2F m2 /\
eval_exp E1 (toRMap defVars) (toREval (Binop Mult e1 e2)) vR M0 /\ eval_exp E1 (toRMap defVars) (toREval (Binop Mult e1 e2)) vR REAL /\
eval_exp (updEnv 2 e2F (updEnv 1 e1F emptyEnv)) (updDefVars 2 m2 (updDefVars 1 m1 defVars)) (Binop Mult (Var 1) (Var 2)) vF m /\ eval_exp (updEnv 2 e2F (updEnv 1 e1F emptyEnv))
(updDefVars 2 m2 (updDefVars 1 m1 defVars))
(Binop Mult (Var 1) (Var 2)) vF m /\
abs (e1R - e1F) <= err1 /\ abs (e1R - e1F) <= err1 /\
abs (e2R - e2F) <= err2 ==> abs (e2R - e2F) <= err2 ==>
abs (vR - vF) <= abs (e1R * e2R - e1F * e2F) + (abs (e1F * e2F) * (mTypeToR m))``, abs (vR - vF) <= abs (e1R * e2R - e1F * e2F) + computeError (e1F * e2F) m``,
rpt strip_tac rpt strip_tac
\\ qpat_x_assum `eval_exp E1 _ (toREval (Binop Mult e1 e2)) _ _` (fn thm => assume_tac (ONCE_REWRITE_RULE [toREval_def] thm)) \\ fs[toREval_def]
\\ fs []
\\ inversion `eval_exp E1 _ (Binop Mult _ _) _ _` eval_exp_cases \\ inversion `eval_exp E1 _ (Binop Mult _ _) _ _` eval_exp_cases
\\ rename1 `vR = perturb (evalBinop Mult v1R v2R) deltaR` \\ rename1 `vR = perturb (evalBinop Mult v1R v2R) (join m1R m2R) deltaR`
\\ inversion `eval_exp _ _ (Binop Mult (Var 1) (Var 2)) _ _` eval_exp_cases \\ inversion `eval_exp _ _ (Binop Mult (Var 1) (Var 2)) _ _` eval_exp_cases
\\ rename1 `vF = perturb (evalBinop Mult v1F v2F) deltaF` \\ rename1 `vF = perturb (evalBinop Mult v1F v2F) (join m1F m2F) deltaF`
\\ `(m1' = M0) /\ (m2' = M0)` by (conj_tac \\ irule toRMap_eval_M0\\ asm_exists_tac \\ fs[]) \\ fs [] \\ `(m1R = REAL) /\ (m2R = REAL)`
\\ rpt (qpat_x_assum `M0 = _` (fn thm => fs [GSYM thm])) by (conj_tac \\ irule toRMap_eval_REAL\\ asm_exists_tac \\ fs[])
\\ `perturb (evalBinop Mult v1R v2R) deltaR = evalBinop Mult v1R v2R` by (match_mp_tac delta_M0_deterministic \\ fs[]) \\ rveq
\\ `vR = evalBinop Mult v1R v2R` by simp[] \\ fs[perturb_def, evalBinop_def]
\\ `v1R = e1R` by metis_tac[meps_0_deterministic] \\ `v1R = e1R` by metis_tac[meps_0_deterministic]
\\ `v2R = e2R` by metis_tac[meps_0_deterministic] \\ `v2R = e2R` by metis_tac[meps_0_deterministic]
\\ fs[evalBinop_def, perturb_def] \\ rveq
\\ rpt (inversion `eval_exp (updEnv 2 e2F (updEnv 1 e1F emptyEnv)) _ _ _ _` eval_exp_cases) \\ rpt (inversion `eval_exp (updEnv 2 e2F (updEnv 1 e1F emptyEnv)) _ _ _ _`
eval_exp_cases)
\\ fs [updEnv_def] \\ rveq \\ fs [updEnv_def] \\ rveq
\\ fs [updDefVars_def] \\ rveq
\\ rewrite_tac [real_sub] \\ rewrite_tac [real_sub]
\\ `e1R * e2R + -(e1F * e2F * (1 + deltaF)) = (e1R * e2R + - (e1F * e2F)) + - (e1F * e2F * deltaF)` by REAL_ASM_ARITH_TAC \\ Cases_on `join m1 m2` \\ fs[join_def, perturb_def]
>- (rewrite_tac [REAL_LE_ADDR] \\ fs[computeError_def])
>- (float_mul_tac)
>- (float_mul_tac)
>- (float_mul_tac)
\\ `e1R * e2R + - (e1F * e2F + deltaF) =
(e1R * e2R + - (e1F * e2F)) + - deltaF`
by REAL_ASM_ARITH_TAC
\\ simp[]
\\ triangle_tac
\\ fs[ABS_NEG, computeError_def]);
val float_div_tac =
(`e1R / e2R + -(e1F / e2F * (1 + deltaF)) =
(e1R / e2R + - (e1F / e2F)) + - (e1F / e2F * deltaF)`
by REAL_ASM_ARITH_TAC
\\ simp[] \\ simp[]
\\ qspecl_then [`abs (e1R * e2R + -(e1F * e2F)) + abs (- e1F * e2F * deltaF)`] match_mp_tac real_le_trans2 \\ irule REAL_LE_TRANS
\\ qexists_tac `abs (e1R / e2R + - (e1F / e2F)) + abs(- (e1F / e2F * deltaF))`
\\ conj_tac \\ conj_tac
>- (REAL_ASM_ARITH_TAC) >- (REAL_ASM_ARITH_TAC)
>- (match_mp_tac REAL_LE_ADD2 \\ irule REAL_LE_ADD2 \\ fs[ABS_NEG, computeError_def]
\\ conj_tac \\ TRY (REAL_ASM_ARITH_TAC) \\ once_rewrite_tac[REAL_ABS_MUL]
\\ once_rewrite_tac[REAL_ABS_MUL] \\ match_mp_tac REAL_LE_MUL2 \\ fs[REAL_ABS_POS]);
\\ match_mp_tac REAL_LE_MUL2 \\ fs[REAL_ABS_POS]
\\ once_rewrite_tac[GSYM REAL_NEG_LMUL, REAL_ABS_MUL]
\\ once_rewrite_tac[ABS_NEG] \\ fs[]));
val div_abs_err_bounded = store_thm ("div_abs_err_bounded", val div_abs_err_bounded = store_thm ("div_abs_err_bounded",
``!(e1:real exp) (e1R:real) (e1F:real) (e2:real exp) (e2R:real) (e2F:real) (err1:real) (err2:real) ``!(e1:real exp) (e1R:real) (e1F:real) (e2:real exp) (e2R:real) (e2F:real) (err1:real) (err2:real)
(vR:real) (vF:real) (E1 E2 :env) (m m1 m2:mType) (defVars: num -> mType option). (vR:real) (vF:real) (E1 E2 :env) (m m1 m2:mType) (defVars: num -> mType option).
eval_exp E1 (toRMap defVars) (toREval e1) e1R M0 /\ eval_exp E1 (toRMap defVars) (toREval e1) e1R REAL /\
eval_exp E2 defVars e1 e1F m1 /\ eval_exp E2 defVars e1 e1F m1 /\
eval_exp E1 (toRMap defVars) (toREval e2) e2R M0 /\ eval_exp E1 (toRMap defVars) (toREval e2) e2R REAL /\
eval_exp E2 defVars e2 e2F m2 /\ eval_exp E2 defVars e2 e2F m2 /\
eval_exp E1 (toRMap defVars) (toREval (Binop Div e1 e2)) vR M0 /\ eval_exp E1 (toRMap defVars) (toREval (Binop Div e1 e2)) vR REAL /\
eval_exp (updEnv 2 e2F (updEnv 1 e1F emptyEnv)) (updDefVars 2 m2 (updDefVars 1 m1 defVars)) (Binop Div (Var 1) (Var 2)) vF m /\ eval_exp (updEnv 2 e2F (updEnv 1 e1F emptyEnv))
(updDefVars 2 m2 (updDefVars 1 m1 defVars))
(Binop Div (Var 1) (Var 2)) vF m /\
abs (e1R - e1F) <= err1 /\ abs (e1R - e1F) <= err1 /\
abs (e2R - e2F) <= err2 ==> abs (e2R - e2F) <= err2 ==>
abs (vR - vF) <= abs (e1R / e2R - e1F / e2F) + (abs (e1F / e2F) * (mTypeToR m))``, abs (vR - vF) <= abs (e1R / e2R - e1F / e2F) + computeError (e1F / e2F) m``,
rpt strip_tac rpt strip_tac \\ fs[toREval_def]
\\ qpat_x_assum `eval_exp E1 _ (toREval (Binop Div e1 e2)) _ _` (fn thm => assume_tac (ONCE_REWRITE_RULE [toREval_def] thm))
\\ fs []
\\ inversion `eval_exp E1 _ (Binop Div _ _) _ _` eval_exp_cases \\ inversion `eval_exp E1 _ (Binop Div _ _) _ _` eval_exp_cases
\\ rename1 `vR = perturb (evalBinop Div v1R v2R) deltaR` \\ rename1 `vR = perturb (evalBinop Div v1R v2R) (join m1R m2R) deltaR`
\\ inversion `eval_exp _ _ (Binop Div (Var 1) (Var 2)) _ _` eval_exp_cases \\ inversion `eval_exp _ _ (Binop Div (Var 1) (Var 2)) _ _` eval_exp_cases
\\ rename1 `vF = perturb (evalBinop Div v1F v2F) deltaF` \\ rename1 `vF = perturb (evalBinop Div v1F v2F) (join m1F m2F) deltaF`
\\ `(m1' = M0) /\ (m2' = M0)` by (conj_tac \\ irule toRMap_eval_M0\\ asm_exists_tac \\ fs[]) \\ fs [] \\ `(m1R = REAL) /\ (m2R = REAL)`
\\ rpt (qpat_x_assum `M0 = _` (fn thm => fs [GSYM thm])) by (conj_tac \\ irule toRMap_eval_REAL\\ asm_exists_tac \\ fs[])
\\ `perturb (evalBinop Div v1R v2R) deltaR = evalBinop Div v1R v2R` by (match_mp_tac delta_M0_deterministic \\ fs[]) \\ rveq
\\ `vR = evalBinop Div v1R v2R` by simp[] \\ fs[perturb_def, evalBinop_def]
\\ `v1R = e1R` by metis_tac[meps_0_deterministic] \\ `v1R = e1R` by metis_tac[meps_0_deterministic]
\\ `v2R = e2R` by metis_tac[meps_0_deterministic] \\ `v2R = e2R` by metis_tac[meps_0_deterministic]
\\ fs[evalBinop_def, perturb_def] \\ rveq
\\ rpt (inversion `eval_exp (updEnv 2 e2F (updEnv 1 e1F emptyEnv)) _ _ _ _` eval_exp_cases) \\ rpt (inversion `eval_exp (updEnv 2 e2F (updEnv 1 e1F emptyEnv)) _ _ _ _`
eval_exp_cases)
\\ fs [updEnv_def] \\ rveq \\ fs [updEnv_def] \\ rveq
\\ fs [updDefVars_def] \\ rveq
\\ rewrite_tac [real_sub] \\ rewrite_tac [real_sub]
\\ `e1R / e2R + -(e1F / e2F * (1 + deltaF)) = (e1R / e2R + - (e1F / e2F)) + - (e1F / e2F * deltaF)` by REAL_ASM_ARITH_TAC \\ Cases_on `join m1 m2` \\ fs[join_def, perturb_def]
>- (rewrite_tac [REAL_LE_ADDR] \\ fs[computeError_def])
>- (float_div_tac)
>- (float_div_tac)
>- (float_div_tac)
\\ `e1R / e2R + - (e1F / e2F + deltaF) =
(e1R / e2R + - (e1F / e2F)) + - deltaF`
by REAL_ASM_ARITH_TAC
\\ simp[] \\ simp[]
\\ qspecl_then [`abs (e1R / e2R + -(e1F / e2F)) + abs (- (e1F / e2F * deltaF))`] match_mp_tac real_le_trans2 \\ triangle_tac
\\ conj_tac \\ fs[ABS_NEG, computeError_def]);
>- (REAL_ASM_ARITH_TAC)
>- (match_mp_tac REAL_LE_ADD2 val float_fma_tac =
\\ conj_tac \\ TRY (REAL_ASM_ARITH_TAC) ( `e1R + e2R * e3R + -((e1F + e2F * e3F) * (1 + deltaF)) =
\\ once_rewrite_tac [ABS_NEG] (e1R + e2R * e3R + -(e1F + e2F * e3F)) + (- (e1F + e2F * e3F) * deltaF)`
\\ once_rewrite_tac[REAL_ABS_MUL] by REAL_ASM_ARITH_TAC
\\ match_mp_tac REAL_LE_MUL2 \\ fs[REAL_ABS_POS])); \\ simp[]
\\ triangle_tac
\\ irule REAL_LE_ADD2
\\ TRY (REAL_ASM_ARITH_TAC)
\\ once_rewrite_tac[REAL_ABS_MUL]
\\ irule REAL_LE_MUL2 \\ fs[REAL_ABS_POS]
\\ once_rewrite_tac[GSYM REAL_NEG_LMUL, REAL_ABS_MUL]
\\ once_rewrite_tac[ABS_NEG] \\ fs[]);
val fma_abs_err_bounded = store_thm ("fma_abs_err_bounded", val fma_abs_err_bounded = store_thm ("fma_abs_err_bounded",
``!(e1:real exp) (e1R:real) (e1F:real) (e2:real exp) (e2R:real) (e2F:real) (e3:real exp) (e3R:real) (e3F:real) (err1:real) (err2:real) (err3:real) ``!(e1:real exp) (e1R:real) (e1F:real) (e2:real exp) (e2R:real) (e2F:real)
(e3:real exp) (e3R:real) (e3F:real) (err1:real) (err2:real) (err3:real)
(vR:real) (vF:real) (E1 E2 :env) (m m1 m2 m3:mType) (defVars: num -> mType option). (vR:real) (vF:real) (E1 E2 :env) (m m1 m2 m3:mType) (defVars: num -> mType option).
eval_exp E1 (toRMap defVars) (toREval e1) e1R M0 /\ eval_exp E1 (toRMap defVars) (toREval e1) e1R REAL /\
eval_exp E2 defVars e1 e1F m1 /\