Commit 3d6185b5 authored by Heiko Becker's avatar Heiko Becker

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

parent 2dd19d8d
...@@ -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]
......
...@@ -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)`;
(** (**
......
...@@ -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
......
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
...@@ -150,7 +150,7 @@ val FPRangeValidator_sound = store_thm ( ...@@ -150,7 +150,7 @@ val FPRangeValidator_sound = store_thm (
\\ disch_then drule \\ fs[]) \\ disch_then drule \\ fs[])
\\ once_rewrite_tac [validFloatValue_def] \\ once_rewrite_tac [validFloatValue_def]
\\ `?iv err vR. FloverMapTree_find e A = SOME (iv, err) /\ \\ `?iv err vR. FloverMapTree_find e A = SOME (iv, err) /\
eval_exp E1 (toRMap Gamma) (toREval e) vR M0 /\ eval_exp E1 (toRMap Gamma) (toREval e) vR REAL /\
FST iv <= vR /\ vR <= SND iv` FST iv <= vR /\ vR <= SND iv`
by (drule validIntervalbounds_sound by (drule validIntervalbounds_sound
\\ disch_then (qspecl_then [`fVars`, `E1`, `Gamma`] impl_subgoal_tac) \\ disch_then (qspecl_then [`fVars`, `E1`, `Gamma`] impl_subgoal_tac)
...@@ -256,7 +256,7 @@ val FPRangeValidatorCmd_sound = store_thm ( ...@@ -256,7 +256,7 @@ val FPRangeValidatorCmd_sound = store_thm (
\\ rpt strip_tac \\ rpt strip_tac
\\ metis_tac[]) \\ metis_tac[])
>- (irule swap_Gamma_bstep >- (irule swap_Gamma_bstep
\\ qexists_tac `updDefVars n M0 (toRMap Gamma)` \\ fs[] \\ qexists_tac `updDefVars n REAL (toRMap Gamma)` \\ fs[]
\\ fs [updDefVars_def, REWRITE_RULE [updDefVars_def] Rmap_updVars_comm]) \\ fs [updDefVars_def, REWRITE_RULE [updDefVars_def] Rmap_updVars_comm])
>- (fs[DIFF_DEF, domain_insert, SUBSET_DEF] >- (fs[DIFF_DEF, domain_insert, SUBSET_DEF]
\\ rpt strip_tac \\ first_x_assum irule \\ rpt strip_tac \\ first_x_assum irule
......
This diff is collapsed.
...@@ -196,6 +196,27 @@ fun Flover_compute t = ...@@ -196,6 +196,27 @@ fun Flover_compute t =
(split_pair_case_tac)) \\ fs[]))) (split_pair_case_tac)) \\ fs[])))
end; end;
fun iter_exists_tac ind n =
fn tm =>
if ind < n
then
(part_match_exists_tac
(fn concl => List.nth (strip_conj concl, ind)) tm)
ORELSE (iter_exists_tac (ind+1) n tm)
else
FAIL_TAC (concat ["No matching clause found for ", term_to_string tm]) ;
val try_all:term -> tactic =
fn tm =>
fn (asl, g) =>
let
val len = length (strip_conj (snd (dest_exists g))) in
iter_exists_tac 0 len tm (asl, g)
end;
val find_exists_tac =
first_assum (try_all o concl);
(* val Flover_compute:tactic = *) (* val Flover_compute:tactic = *)
(* fn (g:goal) => *) (* fn (g:goal) => *)
(* let *) (* let *)
......
...@@ -4,8 +4,8 @@ ...@@ -4,8 +4,8 @@
@author: Raphael Monat @author: Raphael Monat
@maintainer: Heiko Becker @maintainer: Heiko Becker
**) **)
open miscTheory realTheory realLib sptreeTheory; open realTheory realLib sptreeTheory;
open RealSimpsTheory; open RealSimpsTheory;
open preamble; open preamble;
val _ = new_theory "MachineType"; val _ = new_theory "MachineType";
...@@ -13,13 +13,13 @@ val _ = new_theory "MachineType"; ...@@ -13,13 +13,13 @@ val _ = new_theory "MachineType";
val _ = temp_overload_on("abs",``real$abs``); val _ = temp_overload_on("abs",``real$abs``);
val _ = Datatype ` val _ = Datatype `
mType = M0 | M16 | M32 | M64(* | M128 | M256 *) mType = REAL | M16 | M32 | M64(* | M128 | M256 *)
|F num num (*first num is word length, second is fractional bits *)`; |F num num (*first num is word length, second is fractional bits *)`;
val mTypeToR_def = Define ` val mTypeToR_def = Define `
mTypeToR (m:mType) : real = mTypeToR (m:mType) : real =
case m of case m of
| M0 => 0 | REAL => 0
| M16 => 1 / (2 pow 11) | M16 => 1 / (2 pow 11)
| M32 => 1 / (2 pow 24) | M32 => 1 / (2 pow 24)
| M64 => 1 / (2 pow 53) | M64 => 1 / (2 pow 53)
...@@ -29,14 +29,10 @@ val mTypeToR_def = Define ` ...@@ -29,14 +29,10 @@ val mTypeToR_def = Define `
(* | M128 => 1 / (2 pow 105) *) (* | M128 => 1 / (2 pow 105) *)
(* | M256 => 1 / (2 pow 211) *)`; (* | M256 => 1 / (2 pow 211) *)`;
val _ = export_rewrites ["mTypeToR_def"];
(* val meps_def = Define `meps = mTypeToR`; *)
val computeError_def = Define ` val computeError_def = Define `
computeError v m = computeError v m =
case m of case m of
| M0 => 0 | REAL => 0
| F w f => mTypeToR m | F w f => mTypeToR m
| _ => abs v * mTypeToR m`; | _ => abs v * mTypeToR m`;
...@@ -50,7 +46,7 @@ val computeError_up = store_thm ( ...@@ -50,7 +46,7 @@ val computeError_up = store_thm (
``!v a b m. ``!v a b m.
abs v <= maxAbs (a,b) ==> abs v <= maxAbs (a,b) ==>
computeError v m <= computeError (maxAbs (a,b)) m``, computeError v m <= computeError (maxAbs (a,b)) m``,
rpt strip_tac \\ Cases_on `m` \\ fs[computeError_def] \\ TRY RealArith.REAL_ASM_ARITH_TAC rpt strip_tac \\ Cases_on `m` \\ fs[mTypeToR_def, computeError_def] \\ TRY RealArith.REAL_ASM_ARITH_TAC
\\ irule REAL_LE_RMUL_IMP \\ fs[] \\ irule REAL_LE_RMUL_IMP \\ fs[]
\\ fs[maxAbs_def] \\ fs[maxAbs_def]
\\ `abs (real$max (abs a) (abs b)) = real$max (abs a) (abs b)` \\ `abs (real$max (abs a) (abs b)) = real$max (abs a) (abs b)`
...@@ -62,28 +58,28 @@ val computeError_up = store_thm ( ...@@ -62,28 +58,28 @@ val computeError_up = store_thm (
(** (**
Check if machine precision m1 is more precise than machine precision m2. Check if machine precision m1 is more precise than machine precision m2.
M0 is real-valued evaluation, hence the most precise. REAL is real-valued evaluation, hence the most precise.
All others are compared by All others are compared by
mTypeToR m1 <= mTypeToR m2 mTypeToR m1 <= mTypeToR m2
**) **)
val isMorePrecise_def = Define ` val isMorePrecise_def = Define `
isMorePrecise (m1:mType) (m2:mType) = isMorePrecise (m1:mType) (m2:mType) =
case m1, m2 of case m1, m2 of
| M0, _ => T | REAL, _ => T
| F w1 f1, F w2 f2 => w1 <= w2 | F w1 f1, F w2 f2 => w1 <= w2
| F w f, _ => F | F w f, _ => F
| _, F w f => F | _, F w f => F
| _, _ => (mTypeToR (m1) <= mTypeToR (m2))`; | _, _ => (mTypeToR (m1) <= mTypeToR (m2))`;
val morePrecise_def = Define ` val morePrecise_def = Define `
(morePrecise M0 _ = T) /\ (morePrecise REAL _ = T) /\
(morePrecise (F w1 f1) (F w2 f2) = (w1 <= w2)) /\ (morePrecise (F w1 f1) (F w2 f2) = (w1 <= w2)) /\
(morePrecise (F w f) _ = F) /\ (morePrecise (F w f) _ = F) /\
(morePrecise _ (F w f) = F) /\ (morePrecise _ (F w f) = F) /\
(morePrecise M16 M16 = T) /\ (morePrecise M16 M16 = T) /\
(morePrecise M32 M32 = T) /\ (morePrecise M32 M32 = T) /\
(morePrecise M32 M16 = T) /\ (morePrecise M32 M16 = T) /\
(morePrecise M64 M0 = F) /\ (morePrecise M64 REAL = F) /\
(morePrecise M64 _ = T) /\ (morePrecise M64 _ = T) /\
(morePrecise _ _ = F) `; (morePrecise _ _ = F) `;
...@@ -114,18 +110,18 @@ val isMorePrecise_morePrecise = store_thm ( ...@@ -114,18 +110,18 @@ val isMorePrecise_morePrecise = store_thm (
\\ once_rewrite_tac [morePrecise_def, isMorePrecise_def] \\ once_rewrite_tac [morePrecise_def, isMorePrecise_def]
\\ fs[morePrecise_def, isMorePrecise_def, mTypeToR_def]); \\ fs[morePrecise_def, isMorePrecise_def, mTypeToR_def]);
val M0_least_precision = store_thm ("M0_least_precision", val REAL_least_precision = store_thm ("REAL_least_precision",
``!(m:mType). ``!(m:mType).
isMorePrecise m M0 ==> isMorePrecise m REAL ==>
m = M0``, m = REAL``,
fs [isMorePrecise_def, mTypeToR_def] \\ fs [isMorePrecise_def, mTypeToR_def] \\
rpt strip_tac \\ rpt strip_tac \\
Cases_on `m` \\ Cases_on `m` \\
fs []); fs []);
val M0_lower_bound = store_thm ("M0_lower_bound", val REAL_lower_bound = store_thm ("REAL_lower_bound",
``! (m:mType). ``! (m:mType).
isMorePrecise M0 m``, isMorePrecise REAL m``,
Cases_on `m` \\ EVAL_TAC); Cases_on `m` \\ EVAL_TAC);
(** (**
...@@ -140,24 +136,24 @@ val join_def = Define ` ...@@ -140,24 +136,24 @@ val join_def = Define `
val join3_def = Define ` val join3_def = Define `
join3 (m1: mType) (m2: mType) (m3: mType) = join m1 (join m2 m3)`; join3 (m1: mType) (m2: mType) (m3: mType) = join m1 (join m2 m3)`;
(* val M0_join_is_M0 = store_thm ("M0_join_is_M0", *) (* val REAL_join_is_REAL = store_thm ("REAL_join_is_REAL", *)
(* ``!m1 m2. *) (* ``!m1 m2. *)
(* join m1 m2 = M0 ==> *) (* join m1 m2 = REAL ==> *)
(* (m1 = M0 /\ m2 = M0)``, *) (* (m1 = REAL /\ m2 = REAL)``, *)
(* fs [join_def, isMorePrecise_def] *) (* fs [join_def, isMorePrecise_def] *)
(* \\ rpt strip_tac *) (* \\ rpt strip_tac *)
(* \\ Cases_on `m1 = M0` \\ Cases_on `m2 = M0` \\ fs[] *) (* \\ Cases_on `m1 = REAL` \\ Cases_on `m2 = REAL` \\ fs[] *)
(* >- (m1 = M0 by (Cases_on `mTypeToR m1 <= mTypeToR M0` \\ fs[] *) (* >- (m1 = REAL by (Cases_on `mTypeToR m1 <= mTypeToR REAL` \\ fs[] *)
(* \\ fs [ONCE_REWRITE_RULE [isMorePrecise_def] M0_least_precision] *) (* \\ fs [ONCE_REWRITE_RULE [isMorePrecise_def] REAL_least_precision] *)
(* \\ Cases_on `m1` \\ fs[mTypeToR_def] *) (* \\ Cases_on `m1` \\ fs[mTypeToR_def] *)
(* \\ Cases_on `m2` \\ fs[mTypeToR_def] *) (* \\ Cases_on `m2` \\ fs[mTypeToR_def] *)
(* qpat_x_assum `_ = M0` *) (* qpat_x_assum `_ = REAL` *)
(* (fn thm => fs [thm]) *) (* (fn thm => fs [thm]) *)
(* >- (Cases_on `m1` \\ fs [mTypeToR_def]) *) (* >- (Cases_on `m1` \\ fs [mTypeToR_def]) *)
(* >- (Cases_on `m2` \\ fs [mTypeToR_def])); *) (* >- (Cases_on `m2` \\ fs [mTypeToR_def])); *)
val maxExponent_def = Define ` val maxExponent_def = Define `
(maxExponent (M0) = 0n) /\ (maxExponent (REAL) = 0n) /\
(maxExponent (M16) = 15) /\ (maxExponent (M16) = 15) /\
(maxExponent (M32) = 127) /\ (maxExponent (M32) = 127) /\
(maxExponent (M64) = 1023) /\ (maxExponent (M64) = 1023) /\
...@@ -166,7 +162,7 @@ val maxExponent_def = Define ` ...@@ -166,7 +162,7 @@ val maxExponent_def = Define `
(* | M256 => 1023 *)`; (* | M256 => 1023 *)`;
val minExponentPos_def = Define ` val minExponentPos_def = Define `
(minExponentPos (M0) = 0n) /\ (minExponentPos (REAL) = 0n) /\
(minExponentPos (M16) = 14) /\ (minExponentPos (M16) = 14) /\
(minExponentPos (M32) = 126) /\ (minExponentPos (M32) = 126) /\
(minExponentPos (M64) = 1022) /\ (minExponentPos (M64) = 1022) /\
...@@ -210,7 +206,7 @@ val normal_def = Define ` ...@@ -210,7 +206,7 @@ val normal_def = Define `
val denormal_def = Define ` val denormal_def = Define `
denormal (v:real) (m:mType) = denormal (v:real) (m:mType) =
case m of case m of
| M0 => F | REAL => F
| _ => ((abs v) < (minValue_pos m) /\ v <> 0)`; | _ => ((abs v) < (minValue_pos m) /\ v <> 0)`;
(** (**
...@@ -222,13 +218,13 @@ val denormal_def = Define ` ...@@ -222,13 +218,13 @@ val denormal_def = Define `
val validFloatValue_def = Define ` val validFloatValue_def = Define `
validFloatValue (v:real) (m:mType) = validFloatValue (v:real) (m:mType) =
case m of case m of
| M0 => T | REAL => T
| _ => normal v m \/ denormal v m \/ v = 0` | _ => normal v m \/ denormal v m \/ v = 0`
val validValue_def = Define ` val validValue_def = Define `
validValue (v:real) (m:mType) = validValue (v:real) (m:mType) =
case m of case m of
| M0 => T | REAL => T
| _ => abs v <= maxValue m`; | _ => abs v <= maxValue m`;
val no_underflow_fixed_point = store_thm ( val no_underflow_fixed_point = store_thm (
......
...@@ -142,7 +142,7 @@ val validIntervalbounds_sound = store_thm ("validIntervalbounds_sound", ...@@ -142,7 +142,7 @@ val validIntervalbounds_sound = store_thm ("validIntervalbounds_sound",
vars_typed ((domain fVars) UNION (domain dVars)) Gamma ==> vars_typed ((domain fVars) UNION (domain dVars)) Gamma ==>
? iv err vR. ? iv err vR.
FloverMapTree_find f A = SOME(iv, err) /\ FloverMapTree_find f A = SOME(iv, err) /\
eval_exp E (toRMap Gamma) (toREval f) vR M0 /\ eval_exp E (toRMap Gamma) (toREval f) vR REAL /\
(FST iv) <= vR /\ vR <= (SND iv)``, (FST iv) <= vR /\ vR <= (SND iv)``,
Induct_on `f` Induct_on `f`
\\ once_rewrite_tac [usedVars_def, toREval_def] \\ rpt strip_tac \\ once_rewrite_tac [usedVars_def, toREval_def] \\ rpt strip_tac
...@@ -173,9 +173,7 @@ val validIntervalbounds_sound = store_thm ("validIntervalbounds_sound", ...@@ -173,9 +173,7 @@ val validIntervalbounds_sound = store_thm ("validIntervalbounds_sound",
\\ irule REAL_LE_TRANS \\ asm_exists_tac \\ fs[] \\ rveq \\ fs[]) \\ irule REAL_LE_TRANS \\ asm_exists_tac \\ fs[] \\ rveq \\ fs[])
(* Const case *) (* Const case *)
>- (qexists_tac `v` \\ fs[] >- (qexists_tac `v` \\ fs[]
\\ irule Const_dist' \\ fs[] \\ irule Const_dist' \\ fs[perturb_def, mTypeToR_def])
\\ qexists_tac `0` \\ fs[perturb_def]
\\ irule mTypeToR_pos)
(* Unary operator case *) (* Unary operator case *)
>- (first_x_assum (qspecl_then [`A`, `P`, `fVars`, `dVars`, `E`, `Gamma`] destruct) >- (first_x_assum (qspecl_then [`A`, `P`, `fVars`, `dVars`, `E`, `Gamma`] destruct)
\\ fs[] \\ fs[]
...@@ -185,12 +183,12 @@ val validIntervalbounds_sound = store_thm ("validIntervalbounds_sound", ...@@ -185,12 +183,12 @@ val validIntervalbounds_sound = store_thm ("validIntervalbounds_sound",
>- (qexists_tac `- vR` \\ fs[negateInterval_def, isSupersetInterval_def] >- (qexists_tac `- vR` \\ fs[negateInterval_def, isSupersetInterval_def]
\\ Cases_on `iv` \\ fs[IVlo_def, IVhi_def] \\ Cases_on `iv` \\ fs[IVlo_def, IVhi_def]
\\ rpt conj_tac \\ TRY REAL_ASM_ARITH_TAC \\ rpt conj_tac \\ TRY REAL_ASM_ARITH_TAC
\\ irule Unop_neg' \\ qexistsl_tac [`M0`, `vR`] \\ fs[evalUnop_def]) \\ irule Unop_neg' \\ qexistsl_tac [`REAL`, `vR`] \\ fs[evalUnop_def])
(* Inversion case *) (* Inversion case *)
\\ qexists_tac `1 / vR` \\ qexists_tac `1 / vR`
\\ conj_tac \\ conj_tac
>- (irule Unop_inv' \\ fs[] \\ qexistsl_tac [`0`, `vR`] >- (irule Unop_inv' \\ fs[mTypeToR_def] \\ qexistsl_tac [`vR`]
\\ fs[evalUnop_def, perturb_def, REAL_INV_1OVER, mTypeToR_pos, IVhi_def, IVlo_def] \\ fs[evalUnop_def, mTypeToR_def, perturb_def, REAL_INV_1OVER, mTypeToR_pos, IVhi_def, IVlo_def]
\\ CCONTR_TAC \\ fs[] \\ rveq \\ CCONTR_TAC \\ fs[] \\ rveq
\\ `0 < 0:real` by (REAL_ASM_ARITH_TAC) \\ `0 < 0:real` by (REAL_ASM_ARITH_TAC)
\\ fs[]) \\ fs[])
...@@ -216,12 +214,12 @@ val validIntervalbounds_sound = store_thm ("validIntervalbounds_sound", ...@@ -216,12 +214,12 @@ val validIntervalbounds_sound = store_thm ("validIntervalbounds_sound",
(qspecl_then [`A`, `P`, `fVars`, `dVars`, `E`, `Gamma`] destruct) (qspecl_then [`A`, `P`, `fVars`, `dVars`, `E`, `Gamma`] destruct)
\\ fs[domain_union, UNION_DEF, DIFF_DEF, SUBSET_DEF]) \\ fs[domain_union, UNION_DEF, DIFF_DEF, SUBSET_DEF])
\\ rveq \\ rveq
\\ rename1 `eval_exp E (toRMap Gamma) (toREval f1) vR1 M0` \\ rename1 `eval_exp E (toRMap Gamma) (toREval f1) vR1 REAL`
\\ rename1 `eval_exp E (toRMap Gamma) (toREval f2) vR2 M0` \\ rename1 `eval_exp E (toRMap Gamma) (toREval f2) vR2 REAL`
\\ qexists_tac `evalBinop b vR1 vR2` \\ qexists_tac `evalBinop b vR1 vR2`
\\ conj_tac \\ conj_tac
>- (irule Binop_dist' >- (irule Binop_dist' \\ fs[mTypeToR_def]
\\ qexistsl_tac [`0:real`, `M0`, `M0`, `vR1`, `vR2`] \\ qexistsl_tac [`REAL`, `REAL`, `vR1`, `vR2`]
\\ fs[join_def, mTypeToR_pos, perturb_def] \\ fs[join_def, mTypeToR_pos, perturb_def]
\\ strip_tac \\ rveq \\ fs[IVlo_def, IVhi_def] \\ strip_tac \\ rveq \\ fs[IVlo_def, IVhi_def]
\\ CCONTR_TAC \\ fs[] \\ rveq \\ CCONTR_TAC \\ fs[] \\ rveq
...@@ -282,7 +280,6 @@ val validIntervalbounds_sound = store_thm ("validIntervalbounds_sound", ...@@ -282,7 +280,6 @@ val validIntervalbounds_sound = store_thm ("validIntervalbounds_sound",
GSYM REAL_INV_1OVER] GSYM REAL_INV_1OVER]
interval_division_valid) interval_division_valid)
\\ qpat_x_assum `!x. _` kall_tac \\ REAL_ASM_ARITH_TAC) \\ qpat_x_assum `!x. _` kall_tac \\ REAL_ASM_ARITH_TAC)
(** MARKER **)
(* FMA case *) (* FMA case *)
>- (rename1 `Fma (toREval f1) (toREval f2) (toREval f3)` >- (rename1 `Fma (toREval f1) (toREval f2) (toREval f3)`
\\ rpt ( \\ rpt (
...@@ -290,13 +287,13 @@ val validIntervalbounds_sound = store_thm ("validIntervalbounds_sound", ...@@ -290,13 +287,13 @@ val validIntervalbounds_sound = store_thm ("validIntervalbounds_sound",
(qspecl_then [`A`, `P`, `fVars`, `dVars`, `E`, `Gamma`] destruct) (qspecl_then [`A`, `P`, `fVars`, `dVars`, `E`, `Gamma`] destruct)
\\ fs[domain_union, UNION_DEF, DIFF_DEF, SUBSET_DEF]) \\ fs[domain_union, UNION_DEF, DIFF_DEF, SUBSET_DEF])
\\ rveq \\ rveq
\\ rename1 `eval_exp E (toRMap Gamma) (toREval f1) vR1 M0` \\ rename1 `eval_exp E (toRMap Gamma) (toREval f1) vR1 REAL`
\\ rename1 `eval_exp E (toRMap Gamma) (toREval f2) vR2 M0` \\ rename1 `eval_exp E (toRMap Gamma) (toREval f2) vR2 REAL`
\\ rename1 `eval_exp E (toRMap Gamma) (toREval f3) vR3 M0` \\ rename1 `eval_exp E (toRMap Gamma) (toREval f3) vR3 REAL`
\\ qexists_tac `evalFma vR1 vR2 vR3` \\ qexists_tac `evalFma vR1 vR2 vR3`
\\ conj_tac \\ conj_tac
>- (irule Fma_dist' >- (irule Fma_dist'
\\ qexistsl_tac [`0:real`, `M0`, `M0`, `M0`, `vR1`, `vR2`, `vR3`] \\ qexistsl_tac [`0:real`, `REAL`, `REAL`, `REAL`, `vR1`, `vR2`, `vR3`]
\\ fs [mTypeToR_def, perturb_def, evalFma_def, evalBinop_def, join3_def, join_def]) \\ fs [mTypeToR_def, perturb_def, evalFma_def, evalBinop_def, join3_def, join_def])
\\ rename1 `FloverMapTree_find f1 A = SOME (iv_f1, err1)` \\ rename1 `FloverMapTree_find f1 A = SOME (iv_f1, err1)`
\\ rename1 `FloverMapTree_find f2 A = SOME (iv_f2, err2)` \\ rename1 `FloverMapTree_find f2 A = SOME (iv_f2, err2)`
...@@ -331,7 +328,8 @@ val validIntervalbounds_sound = store_thm ("validIntervalbounds_sound", ...@@ -331,7 +328,8 @@ val validIntervalbounds_sound = store_thm ("validIntervalbounds_sound",
\\ qexists_tac `vR` \\ fs[Downcast_dist', isSupersetInterval_def, IVlo_def, IVhi_def] \\ qexists_tac `vR` \\ fs[Downcast_dist', isSupersetInterval_def, IVlo_def, IVhi_def]
\\ `FST iv = FST intv` by (metis_tac [REAL_LE_ANTISYM]) \\ `FST iv = FST intv` by (metis_tac [REAL_LE_ANTISYM])
\\ `SND iv = SND intv` by (metis_tac [REAL_LE_ANTISYM]) \\ `SND iv = SND intv` by (metis_tac [REAL_LE_ANTISYM])
\\ fs[])); \\ fs[]
));
val getRetExp_def = Define ` val getRetExp_def = Define `
(getRetExp (Let m x e g) = getRetExp g) /\ (getRetExp (Let m x e g) = getRetExp g) /\
...@@ -340,7 +338,7 @@ val getRetExp_def = Define ` ...@@ -340,7 +338,7 @@ val getRetExp_def = Define `
val Rmap_updVars_comm = store_thm ( val Rmap_updVars_comm = store_thm (
"Rmap_updVars_comm", "Rmap_updVars_comm",
``!Gamma n m x. ``!Gamma n m x.
updDefVars n M0 (toRMap Gamma) x = toRMap (updDefVars n m Gamma) x``, updDefVars n REAL (toRMap Gamma) x = toRMap (updDefVars n m Gamma) x``,
fs [updDefVars_def, toRMap_def] fs [updDefVars_def, toRMap_def]
\\ rpt strip_tac \\ rpt strip_tac
\\ Cases_on `x = n` \\ fs[]); \\ Cases_on `x = n` \\ fs[]);
...@@ -388,7 +386,7 @@ val validIntervalboundsCmd_sound = store_thm ("validIntervalboundsCmd_sound", ...@@ -388,7 +386,7 @@ val validIntervalboundsCmd_sound = store_thm ("validIntervalboundsCmd_sound",
validIntervalboundsCmd f A P dVars ==> validIntervalboundsCmd f A P dVars ==>
?iv err vR. ?iv err vR.
FloverMapTree_find (getRetExp f) A = SOME (iv, err) /\ FloverMapTree_find (getRetExp f) A = SOME (iv, err) /\
(bstep (toREvalCmd f) E (toRMap Gamma) vR M0 /\ (bstep (toREvalCmd f) E (toRMap Gamma) vR REAL /\
FST iv <= vR /\ vR <= SND iv)``, FST iv <= vR /\ vR <= SND iv)``,
Induct_on `f` Induct_on `f`
\\ rpt gen_tac \\ rpt gen_tac
...@@ -404,7 +402,7 @@ val validIntervalboundsCmd_sound = store_thm ("validIntervalboundsCmd_sound", ...@@ -404,7 +402,7 @@ val validIntervalboundsCmd_sound = store_thm ("validIntervalboundsCmd_sound",
\\ rename1 `FloverMapTree_find e A = SOME (iv_e, err_e)` \\ rename1 `FloverMapTree_find e A = SOME (iv_e, err_e)`
\\ first_x_assum \\ first_x_assum
(qspecl_then [`A`, `updEnv n vR E`, `fVars`, `insert n () dVars`, (qspecl_then [`A`, `updEnv n vR E`, `fVars`, `insert n () dVars`,
`outVars`, `P`, `updDefVars n M0 Gamma`] `outVars`, `P`, `updDefVars n REAL Gamma`]
destruct) destruct)
>- (fs [domain_insert] >- (fs [domain_insert]
\\ rpt conj_tac \\ rpt conj_tac
...@@ -436,7 +434,7 @@ val validIntervalboundsCmd_sound = store_thm ("validIntervalboundsCmd_sound", ...@@ -436,7 +434,7 @@ val validIntervalboundsCmd_sound = store_thm ("validIntervalboundsCmd_sound",
\\ fs[] \\ fs[]
\\ irule let_b \\ qexists_tac `vR` \\ fs[] \\ irule let_b \\ qexists_tac `vR` \\ fs[]
\\ irule swap_Gamma_bstep \\ irule swap_Gamma_bstep
\\ qexists_tac `(toRMap (updDefVars n M0 Gamma))` \\ qexists_tac `(toRMap (updDefVars n REAL Gamma))`
\\ fs[Rmap_updVars_comm]) \\ fs[Rmap_updVars_comm])
>- (inversion `ssa _ _ _` ssa_cases >- (inversion `ssa _ _ _` ssa_cases
\\ drule validIntervalbounds_sound \\ drule validIntervalbounds_sound
......
...@@ -23,7 +23,7 @@ then ...@@ -23,7 +23,7 @@ then
exit 1 exit 1
fi fi
DIR=pwd DIR="$(pwd)"
HOLCOMMIT="$(cat ./.HOLCOMMIT)" HOLCOMMIT="$(cat ./.HOLCOMMIT)"
if [[ "$INIT" = "yes" ]]; if [[ "$INIT" = "yes" ]];
......
...@@ -156,7 +156,7 @@ val ssa_shadowing_free = store_thm ("ssa_shadowing_free", ...@@ -156,7 +156,7 @@ val ssa_shadowing_free = store_thm ("ssa_shadowing_free",
``!m x y v v' e f inVars outVars E defVars. ``!m x y v v' e f inVars outVars E defVars.
ssa (Let m x (toREval e) (toREvalCmd f)) inVars outVars /\ ssa (Let m x (toREval e) (toREvalCmd f)) inVars outVars /\
(y IN (domain inVars)) /\ (y IN (domain inVars)) /\
eval_exp E defVars (toREval e) v M0 ==> eval_exp E defVars (toREval e) v REAL ==>
!E n. updEnv x v (updEnv y v' E) n = updEnv y v' (updEnv x v E) n``, !E n. updEnv x v (updEnv y v' E) n = updEnv y v' (updEnv x v E) n``,
rpt strip_tac rpt strip_tac
\\ inversion `ssa (Let m x (toREval e) (toREvalCmd f)) _ _` ssa_cases \\ inversion `ssa (Let m x (toREval e) (toREvalCmd f)) _ _` ssa_cases
...@@ -170,23 +170,23 @@ val ssa_shadowing_free = store_thm ("ssa_shadowing_free", ...@@ -170,23 +170,23 @@ val ssa_shadowing_free = store_thm ("ssa_shadowing_free",
(* val shadowing_free_rewriting_exp = store_thm ("shadowing_free_rewriting_exp", *) (* val shadowing_free_rewriting_exp = store_thm ("shadowing_free_rewriting_exp", *)
(* ``!e v E1 E2 defVars. *) (* ``!e v E1 E2 defVars. *)
(* (!n. E1 n = E2 n) ==> *) (* (!n. E1 n = E2 n) ==> *)
(* (eval_exp E1 defVars (toREval e) v M0 <=> *) (* (eval_exp E1 defVars (toREval e) v REAL <=> *)
(* eval_exp E2 defVars (toREval e) v M0)``, *) (* eval_exp E2 defVars (toREval e) v REAL)``, *)
(* Induct \\ rpt strip_tac \\ fs[eval_exp_cases, EQ_IMP_THM] \\ metis_tac[]); *) (* Induct \\ rpt strip_tac \\ fs[eval_exp_cases, EQ_IMP_THM] \\ metis_tac[]); *)
(* val shadowing_free_rewriting_cmd = store_thm ("shadowing_free_rewriting_cmd", *) (* val shadowing_free_rewriting_cmd = store_thm ("shadowing_free_rewriting_cmd", *)
(* ``!f E1 E2 vR defVars. *) (* ``!f E1 E2 vR defVars. *)
(* (!n. E1 n = E2 n) ==> *) (* (!n. E1 n = E2 n) ==> *)
(* (bstep (toREvalCmd f) E1 defVars vR M0 <=> *) (* (bstep (toREvalCmd f) E1 defVars vR REAL <=> *)
(* bstep (toREvalCmd f) E2 defVars vR M0)``, *) (* bstep (toREvalCmd f) E2 defVars vR REAL)``, *)
(* Induct \\ rpt strip_tac \\ fs[EQ_IMP_THM] \\ metis_tac[]); *) (* Induct \\ rpt strip_tac \\ fs[EQ_IMP_THM] \\ metis_tac[]); *)
(* val dummy_bind_ok = store_thm ("dummy_bind_ok", *) (* val dummy_bind_ok = store_thm ("dummy_bind_ok", *)
(* ``!e v x v' (inVars:num_set) E defVars. *) (* ``!e v x v' (inVars:num_set) E defVars. *)
(* (domain (usedVars e)) SUBSET (domain inVars) /\ *) (* (domain (usedVars e)) SUBSET (domain inVars) /\ *)
(* (~ (x IN (domain inVars))) /\ *) (* (~ (x IN (domain inVars))) /\ *)
(* eval_exp E defVars (toREval e) v M0 ==> *) (* eval_exp E defVars (toREval e) v REAL ==> *)
(* eval_exp (updEnv x v' E) defVars (toREval e) v M0``, *) (* eval_exp (updEnv x v' E) defVars (toREval e) v REAL``, *)
(* Induct \\ rpt strip_tac \\ once_rewrite_tac [toREval_def] \\ qpat_x_assum `eval_exp _ _ (toREval _) _ _` (fn thm => assume_tac (ONCE_REWRITE_RULE [toREval_def] thm)) \\ fs [] \\ rveq \\ inversion `eval_exp _ _ _ _ _` eval_exp_cases *) (* Induct \\ rpt strip_tac \\ once_rewrite_tac [toREval_def] \\ qpat_x_assum `eval_exp _ _ (toREval _) _ _` (fn thm => assume_tac (ONCE_REWRITE_RULE [toREval_def] thm)) \\ fs [] \\ rveq \\ inversion `eval_exp _ _ _ _ _` eval_exp_cases *)
(* >- (match_mp_tac Var_load *) (* >- (match_mp_tac Var_load *)
(* \\ fs[usedVars_def, updEnv_def] *) (* \\ fs[usedVars_def, updEnv_def] *)
...@@ -204,9 +204,9 @@ val ssa_shadowing_free = store_thm ("ssa_shadowing_free", ...@@ -204,9 +204,9 @@ val ssa_shadowing_free = store_thm ("ssa_shadowing_free",
(* \\ qexists_tac `inVars` *) (* \\ qexists_tac `inVars` *)
(* \\ qpat_x_assum `domain _ SUBSET _` (fn thm => assume_tac (ONCE_REWRITE_RULE [usedVars_def] thm)) *) (* \\ qpat_x_assum `domain _ SUBSET _` (fn thm => assume_tac (ONCE_REWRITE_RULE [usedVars_def] thm)) *)
(* \\ fs[])) *) (* \\ fs[])) *)
(* >- (`(m1 = M0) /\ (m2 = M0)` by (match_mp_tac ifJoinIs0 \\ fs[]) *) (* >- (`(m1 = REAL) /\ (m2 = REAL)` by (match_mp_tac ifJoinIs0 \\ fs[]) *)
(* \\ rveq *) (* \\ rveq *)
(* \\ qpat_assum `M0 = _` (fn thm => once_rewrite_tac [thm]) *) (* \\ qpat_assum `REAL = _` (fn thm => once_rewrite_tac [thm]) *)
(* \\ match_mp_tac Binop_dist \\ fs[] *) (* \\ match_mp_tac Binop_dist \\ fs[] *)
(* \\ qpat_x_assum `domain _ SUBSET _` (fn thm => assume_tac (ONCE_REWRITE_RULE [usedVars_def] thm)) *) (* \\ qpat_x_assum `domain _ SUBSET _` (fn thm => assume_tac (ONCE_REWRITE_RULE [usedVars_def] thm)) *)
(* \\ conj_tac \\ first_x_assum match_mp_tac \\ qexists_tac `inVars` \\ fs[domain_union]) *) (* \\ conj_tac \\ first_x_assum match_mp_tac \\ qexists_tac `inVars` \\ fs[domain_union]) *)
......
open simpLib realTheory realLib RealArith stringTheory; open simpLib realTheory realLib RealArith stringTheory;
open ml_translatorTheory ml_translatorLib cfTacticsLib basis basisProgTheory; open ml_translatorTheory ml_translatorLib cfTacticsLib basis basisProgTheory;
open AbbrevsTheory ExpressionsTheory RealSimpsTheory ExpressionAbbrevsTheory open AbbrevsTheory ExpressionsTheory RealSimpsTheory ExpressionAbbrevsTheory
MachineTypeTheory
ErrorBoundsTheory IntervalArithTheory FloverTactics IntervalValidationTheory ErrorBoundsTheory IntervalArithTheory FloverTactics IntervalValidationTheory
EnvironmentsTheory CommandsTheory ssaPrgsTheory ErrorValidationTheory EnvironmentsTheory CommandsTheory ssaPrgsTheory ErrorValidationTheory
CertificateCheckerTheory floverParserTheory; CertificateCheckerTheory floverParserTheory;
...@@ -130,16 +131,16 @@ val _ = translate (MachineTypeTheory.mTypeToR_def ...@@ -130,16 +131,16 @@ val _ = translate (MachineTypeTheory.mTypeToR_def
GSYM const_1_over_2_pow_24_def, GSYM const_1_over_2_pow_24_def,
GSYM const_1_over_2_pow_53_def]); GSYM const_1_over_2_pow_53_def]);
val isMorePrecise_eq = prove( (* val isMorePrecise_eq = prove( *)
``isMorePrecise m1 m2 = (* ``isMorePrecise m1 m2 = *)
case m1 of (* case m1 of *)
| M0 => T (* | REAL => T *)
| M64 => (case m2 of M0 => F | _ => T) (* | M64 => (case m2 of REAL => F | _ => T) *)