Commit 2e3a7e7e authored by Heiko Becker's avatar Heiko Becker

Implement and prove correct new type inferencer in HOL4

parent 4ccb040c
......@@ -40,12 +40,7 @@ val updEnv_def = Define `
val noDivzero_def = Define `noDivzero (a:real) (b:real) = (a < &0 \/ &0 < b)`;
val updDefVars_def = Define `
updDefVars (x:num) (m:mType) (defVars:num -> mType option) (y:num) :mType option =
if y = x then SOME m else defVars y`;
val _ = export_rewrites ["IVlo_def", "IVhi_def",
"emptyEnv_def", "updEnv_def",
"updDefVars_def"]
"emptyEnv_def", "updEnv_def"]
val _ = export_theory();
......@@ -2,7 +2,8 @@
Formalization of the Abstract Syntax Tree of a subset used in the Flover framework
**)
open simpLib realTheory realLib RealArith
open AbbrevsTheory ExpressionsTheory ExpressionAbbrevsTheory MachineTypeTheory
open AbbrevsTheory ExpressionsTheory ExpressionAbbrevsTheory
ExpressionSemanticsTheory MachineTypeTheory;
open preamble
val _ = new_theory "Commands";
......@@ -27,21 +28,21 @@ val toREvalCmd_def = Define `
result value
**)
val (bstep_rules, bstep_ind, bstep_cases) = Hol_reln `
(!m m' x e s E v res Gamma fBits.
eval_expr E Gamma fBits e v m /\
bstep s (updEnv x v E) (updDefVars x m Gamma) fBits res m' ==>
bstep (Let m x e s) E Gamma fBits res m') /\
(!m e E v Gamma fBits.
eval_expr E Gamma fBits e v m ==>
bstep (Ret e) E Gamma fBits v m)`;
(!m m' x e s E v res Gamma.
eval_expr E Gamma e v m /\
bstep s (updEnv x v E) Gamma res m' ==>
bstep (Let m x e s) E Gamma res m') /\
(!m e E v Gamma.
eval_expr E Gamma e v m ==>
bstep (Ret e) E Gamma v m)`;
(**
Generate a better case lemma again
Generate a better case lemma
**)
val bstep_cases =
map (GEN_ALL o SIMP_CONV (srw_ss()) [Once bstep_cases])
[``bstep (Let m x e s) E defVars fBits vR m'``,
``bstep (Ret e) E defVars fBits vR m``]
[``bstep (Let m x e s) E defVars vR m'``,
``bstep (Ret e) E defVars vR m``]
|> LIST_CONJ |> curry save_thm "bstep_cases";
val [let_b, ret_b] = CONJ_LIST 2 bstep_rules;
......@@ -69,10 +70,10 @@ val definedVars_def = Define `
val bstep_eq_env = store_thm (
"bstep_eq_env",
``!f E1 E2 Gamma v m fBits.
``!f E1 E2 Gamma v m.
(!x. E1 x = E2 x) /\
bstep f E1 Gamma fBits v m ==>
bstep f E2 Gamma fBits v m``,
bstep f E1 Gamma v m ==>
bstep f E2 Gamma v m``,
Induct \\ rpt strip_tac \\ fs[bstep_cases]
>- (qexists_tac `v'` \\ conj_tac
\\ TRY (drule eval_eq_env \\ disch_then drule \\ fs[] \\ FAIL_TAC"")
......@@ -80,4 +81,26 @@ val bstep_eq_env = store_thm (
\\ rpt strip_tac \\ fs[updEnv_def])
\\ irule eval_eq_env \\ asm_exists_tac \\ fs[]);
val swap_Gamma_bstep = store_thm (
"swap_Gamma_bstep",
``!f E vR m Gamma1 Gamma2.
(! e. Gamma1 e = Gamma2 e) /\
bstep f E Gamma1 vR m ==>
bstep f E Gamma2 vR m``,
Induct_on `f` \\ rpt strip_tac \\ fs[bstep_cases]
\\ metis_tac [swap_Gamma_eval_expr]);
val bstep_Gamma_det = store_thm (
"bstep_Gamma_det",
``!f E1 E2 Gamma v1 v2 m1 m2.
bstep f E1 Gamma v1 m1 /\
bstep f E2 Gamma v2 m2 ==>
m1 = m2``,
Induct_on `f` \\ rpt strip_tac \\ fs[bstep_cases]
\\ metis_tac[Gamma_det]);
val getRetExp_def = Define `
(getRetExp (Let m x e g) = getRetExp g) /\
(getRetExp (Ret e) = e)`;
val _ = export_theory ();
open simpLib realTheory realLib RealArith sptreeTheory
open AbbrevsTheory ExpressionAbbrevsTheory RealSimpsTheory CommandsTheory FloverTactics FloverMapTheory
open preamble
open simpLib realTheory realLib RealArith sptreeTheory;
open AbbrevsTheory ExpressionAbbrevsTheory RealSimpsTheory CommandsTheory
FloverTactics FloverMapTheory;
open preamble;
val _ = new_theory "Environments";
val _ = temp_overload_on("abs",``real$abs``);
val (approxEnv_rules, approxEnv_ind, approxEnv_cases) = Hol_reln `
(!(defVars: num -> mType option) (A:analysisResult).
approxEnv emptyEnv defVars A LN LN emptyEnv) /\
(!(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 /\
(defVars x = SOME m) /\
(!(Gamma: real expr -> mType option) (A:analysisResult).
approxEnv emptyEnv Gamma A LN LN emptyEnv) /\
(!(E1:env) (E2:env) (Gamma: real expr -> mType option) (A:analysisResult)
(fVars:num_set) (dVars:num_set) v1 v2 x.
approxEnv E1 Gamma A fVars dVars E2 /\
(Gamma (Var x) = SOME m) /\
(abs (v1 - v2) <= computeError v1 m) /\
(lookup x (union fVars dVars) = NONE) ==>
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)
approxEnv (updEnv x v1 E1)
Gamma A (insert x () fVars) dVars
(updEnv x v2 E2)) /\
(!(E1:env) (E2:env) (Gamma: real expr -> mType option) (A:analysisResult)
(fVars:num_set) (dVars:num_set) v1 v2 x iv err.
approxEnv E1 defVars A fVars dVars E2 /\
FloverMapTree_find (Var x) A = SOME (iv, err) /\
approxEnv E1 Gamma A fVars dVars E2 /\
Gamma (Var x) = SOME m /\
FloverMapTree_find (Var x) A = SOME (iv,err) /\
abs (v1 - v2) <= err /\
(lookup x (union fVars dVars) = NONE) ==>
approxEnv (updEnv x v1 E1) (updDefVars x m defVars) A fVars (insert x () dVars) (updEnv x v2 E2))`;
approxEnv (updEnv x v1 E1)
Gamma A fVars (insert x () dVars)
(updEnv x v2 E2))`;
val [approxRefl, approxUpdFree, approxUpdBound] = CONJ_LIST 3 approxEnv_rules;
save_thm ("approxRefl", approxRefl);
......@@ -57,7 +64,7 @@ val approxEnv_fVar_bounded = store_thm (
E1 x = SOME v /\
E2 x = SOME v2 /\
x IN (domain fVars) /\
Gamma x = SOME m ==>
Gamma (Var x) = SOME m ==>
abs (v - v2) <= computeError v m``,
rpt strip_tac
\\ qspec_then
......@@ -66,7 +73,7 @@ val approxEnv_fVar_bounded = store_thm (
E1 x = SOME v /\
E2 x = SOME v2 /\
x IN (domain fVars) /\
Gamma x = SOME m ==>
Gamma (Var x) = SOME m ==>
abs (v - v2) <= computeError v m`
(fn thm => irule (SIMP_RULE std_ss [] thm))
approxEnv_ind
......@@ -74,16 +81,12 @@ val approxEnv_fVar_bounded = store_thm (
>- (fs [])
>- (fs []
\\ EVERY_CASE_TAC \\ rveq \\ fs[lookup_union, domain_lookup]
\\ first_x_assum irule \\ fs[]
\\ rename1 `defVars x2 = SOME m2`
\\ qexists_tac `x2` \\ fs[updDefVars_def])
\\ first_x_assum drule \\ fs[])
>- (fs []
\\ rveq \\ fs[]
\\ EVERY_CASE_TAC
\\ rveq \\ fs[]
\\ first_x_assum irule \\ fs[]
\\ rename1 `defVars x1 = SOME m1` \\ qexists_tac `x1`
\\ fs[])
\\ first_x_assum drule \\ fs[])
\\ qexistsl_tac [`E1`, `Gamma`, `absenv`, `fVars`, `dVars`, `E2`, `x`]
\\ fs[]);
......@@ -93,7 +96,7 @@ val approxEnv_dVar_bounded = store_thm ("approxEnv_dVar_bounded",
E1 x = SOME v /\
E2 x = SOME v2 /\
x IN (domain dVars) /\
Gamma x = SOME m /\
Gamma (Var x) = SOME m /\
FloverMapTree_find (Var x) A = SOME (iv, e) ==>
abs (v - v2) <= e``,
rpt strip_tac
......@@ -103,7 +106,7 @@ val approxEnv_dVar_bounded = store_thm ("approxEnv_dVar_bounded",
E1 x = SOME v /\
E2 x = SOME v2 /\
x IN (domain dVars) /\
Gamma x = SOME m /\
Gamma (Var x) = SOME m /\
FloverMapTree_find (Var x) A = SOME (iv, e) ==>
abs (v - v2) <= e`
(fn thm => destruct (SIMP_RULE std_ss [] thm))
......@@ -113,14 +116,10 @@ val approxEnv_dVar_bounded = store_thm ("approxEnv_dVar_bounded",
>- (rpt strip_tac \\ fs [updEnv_def]
\\ EVERY_CASE_TAC \\ rveq \\ fs[lookup_union, domain_lookup]
>- (EVERY_CASE_TAC \\ fs[])
\\ first_x_assum irule \\ fs[updDefVars_def]
\\ rename1 `defVars x2 = SOME m2` \\ qexistsl_tac [`m2`, `x2`]
\\ fs[])
\\ first_x_assum drule \\ fs[])
>- (rpt strip_tac \\ fs [updEnv_def, updDefVars_def] \\ rveq \\ fs[]
\\ EVERY_CASE_TAC \\ rveq \\ fs[]
\\ first_x_assum irule \\ fs[]
\\ rename1 `defVars x1 = SOME m1` \\ qexistsl_tac [`m1`,`x1`]
\\ fs[]))
\\ first_x_assum drule \\ fs[]))
\\ first_x_assum drule
\\ rpt (disch_then drule)
\\ disch_then MATCH_ACCEPT_TAC);
......
(**
Some abbreviations that require having defined exprressions beforehand
If we would put them in the Abbrevs file, this would create a circular dependency which HOL4 cannot resolve.
Some abbreviations that require having defined expressions beforehand
If we would put them in the Abbrevs file, this would create a circular
dependency
**)
open FloverMapTheory
open preamble
open FloverMapTheory ExpressionsTheory;
open preamble;
val _ = new_theory "ExpressionAbbrevs";
......@@ -12,12 +13,58 @@ We treat a function mapping an exprression arguing on fractions as value type
to pairs of intervals on rationals and rational errors as the analysis result
**)
val _ = type_abbrev ("typeMap", ``:(real expr # mType) binTree``);
val _ = type_abbrev ("bitMap", ``:(real expr # num) binTree``);
val _ = type_abbrev ("analysisResult", ``:(real expr # ((real # real) # real)) binTree``);
val _ = type_abbrev ("fMap", ``:(real expr # 'a) binTree``);
val _ = type_abbrev ("typeMap", ``:mType fMap``);
val _ = type_abbrev ("analysisResult", ``:((real # real) # real) fMap``);
val toRBMap_def = Define `
toRBMap (fBits:bitMap) =
\e. FloverMapTree_find e fBits`;
val updDefVars_def = Define `
updDefVars (x:real expr) (m:mType) (defVars:real expr -> mType option) (y:real expr) :mType option =
if y = x then SOME m else defVars y`;
val toRExpMap_def = Define `
toRExpMap (tMap:typeMap) =
\e. FloverMapTree_find e tMap`;
val toRTMap_def = Define `
toRTMap Gamma (Var v) =
(case Gamma (Var v) of
|SOME m => SOME REAL
|_ => NONE) /\
toRTMap tMap e = SOME REAL`;
val no_cycle_unop = store_thm (
"no_cycle_unop",
``!e u. e <> Unop u e``,
Induct_on `e` \\ fs[expr_distinct]);
val no_cycle_cast = store_thm (
"no_cycle_cast",
``!e m. e <> Downcast m e``,
Induct_on `e` \\ fs[expr_distinct])
val no_cycle_binop_left = store_thm (
"no_cycle_binop_left",
``!e1 e2 b. e1 <> Binop b e1 e2``,
Induct_on `e1` \\ fs[expr_distinct]);
val no_cycle_binop_right = store_thm (
"no_cycle_binop_right",
``!e1 e2 b. e2 <> Binop b e1 e2``,
Induct_on `e2` \\ fs[expr_distinct]);
val no_cycle_fma_left = store_thm (
"no_cycle_fma_left",
``!e1 e2 e3. e1 <> Fma e1 e2 e3``,
Induct_on `e1` \\ fs[expr_distinct]);
val no_cycle_fma_center = store_thm (
"no_cycle_fma_center",
``!e1 e2 e3. e2 <> Fma e1 e2 e3``,
Induct_on `e2` \\ fs[expr_distinct]);
val no_cycle_fma_right = store_thm (
"no_cycle_fma_right",
``!e1 e2 e3. e3 <> Fma e1 e2 e3``,
Induct_on `e3` \\ fs[expr_distinct]);
val _ = export_theory()
This diff is collapsed.
This diff is collapsed.
......@@ -148,4 +148,94 @@ val FloverMapTree_correct = store_thm (
\\ Cases_on `a` \\ fs[FloverMapTree_insert_def]
\\ Cases_on `exprCompare k q` \\ fs[FloverMapTree_find_def, exprCompare_refl]);
val exprCompare_eq = store_thm (
"exprCompare_eq",
``!e1 e2. exprCompare e1 e2 = Eq <=> e1 = e2``,
Induct_on `e1` \\ Cases_on `e2` \\ simp[Once exprCompare_def] \\ rpt strip_tac
>- (EVERY_CASE_TAC \\ fs[])
>- (EVERY_CASE_TAC \\ fs[])
>- (first_x_assum (qspec_then `e` assume_tac)
\\ Cases_on `u' = u` \\ fs[]
\\ EVERY_CASE_TAC \\ fs[])
>- (first_x_assum (qspec_then `e0` assume_tac)
\\ first_x_assum (qspec_then `e` assume_tac)
\\ EVERY_CASE_TAC \\ fs[])
>- (first_x_assum (qspec_then `e1'''` assume_tac)
\\ first_x_assum (qspec_then `e0` assume_tac)
\\ first_x_assum (qspec_then `e` assume_tac)
\\ EVERY_CASE_TAC \\ fs[])
\\ first_x_assum (qspec_then `e` assume_tac)
\\ every_case_tac \\ fs[]);
val exprCompare_neq = store_thm (
"exprCompare_neq",
``!e1 e2. exprCompare e1 e2 <> Eq <=> e1 <> e2``,
Induct_on `e1` \\ Cases_on `e2` \\ simp[Once exprCompare_def] \\ rpt strip_tac
>- (EVERY_CASE_TAC \\ fs[])
>- (EVERY_CASE_TAC \\ fs[])
>- (first_x_assum (qspec_then `e` assume_tac)
\\ Cases_on `u' = u` \\ fs[]
\\ EVERY_CASE_TAC \\ fs[])
>- (first_x_assum (qspec_then `e0` assume_tac)
\\ first_x_assum (qspec_then `e` assume_tac)
\\ EVERY_CASE_TAC \\ fs[])
>- (first_x_assum (qspec_then `e1'''` assume_tac)
\\ first_x_assum (qspec_then `e0` assume_tac)
\\ first_x_assum (qspec_then `e` assume_tac)
\\ EVERY_CASE_TAC \\ fs[])
\\ first_x_assum (qspec_then `e` assume_tac)
\\ every_case_tac \\ fs[]);
val map_find_add = store_thm (
"map_find_add",
``! e1 e2 m map1.
FloverMapTree_find e1 (FloverMapTree_insert e2 m map1) =
if (e1 = e2)
then SOME m
else FloverMapTree_find e1 map1``,
Induct_on `map1` \\ rpt strip_tac
\\ fs[FloverMapTree_insert_def, FloverMapTree_find_def, exprCompare_eq]
>- (Cases_on `a` \\ fs[FloverMapTree_insert_def]
\\ Cases_on `exprCompare e2 q` \\ fs[FloverMapTree_find_def]
\\ Cases_on `exprCompare e1 q` \\ fs[exprCompare_eq] \\ rveq
>- (`e2 <> e1`
by (Cases_on `exprCompare e2 e1 = Eq` \\ fs[exprCompare_neq])
\\ fs[])
>- (Cases_on `e1 = e2` \\ fs[])
>- (`e1 <> e2`
by (Cases_on `exprCompare e1 e2 = Eq` \\ fs[exprCompare_neq])
\\ fs[])
>- (`e1 <> e2`
by (Cases_on `exprCompare e1 e2 = Eq` \\ fs[exprCompare_neq])
\\ fs[])
>- (Cases_on `e1 = e2` \\ fs[])
\\ `e2 <> e1`
by (Cases_on `exprCompare e2 e1 = Eq` \\ fs[exprCompare_neq])
\\ fs[])
\\ Cases_on `a` \\ fs[FloverMapTree_insert_def]
\\ Cases_on `exprCompare e2 q` \\ fs[FloverMapTree_find_def]
\\ Cases_on `exprCompare e1 q` \\ fs[exprCompare_eq] \\ rveq
>- (`e2 <> e1`
by (Cases_on `exprCompare e2 e1 = Eq` \\ fs[exprCompare_neq])
\\ fs[])
>- (Cases_on `e1 = e2` \\ fs[])
>- (`e1 <> e2`
by (Cases_on `exprCompare e1 e2 = Eq` \\ fs[exprCompare_neq])
\\ fs[])
>- (`e1 <> e2`
by (Cases_on `exprCompare e1 e2 = Eq` \\ fs[exprCompare_neq])
\\ fs[])
>- (Cases_on `e1 = e2` \\ fs[])
\\ `e2 <> e1`
by (Cases_on `exprCompare e2 e1 = Eq` \\ fs[exprCompare_neq])
\\ fs[]);
val map_mem_add = store_thm (
"map_mem_add",
``!e1 e2 m map1.
FloverMapTree_mem e1 (FloverMapTree_insert e2 m map1) =
(e1 = e2 \/ FloverMapTree_mem e1 map1)``,
fs[FloverMapTree_mem_def, map_find_add]
\\ rpt strip_tac \\ Cases_on `e1 = e2` \\ fs[]);
val _ = export_theory();
......@@ -11,9 +11,12 @@ open preamble;
val _ = new_theory "MachineType";
val _ = temp_overload_on("abs",``real$abs``);
val _ = monadsyntax.enable_monadsyntax();
val _ = List.app monadsyntax.enable_monad ["option"];
val _ = Datatype `
mType = REAL | M16 | M32 | M64(* | M128 | M256 *)
mType = REAL
| M16 | M32 | M64
|F num num (*first num is word length, second is fractional bits *)`;
val isFixedPoint_def = Define `
......@@ -27,11 +30,7 @@ val mTypeToR_def = Define `
| M16 => 1 / (2 pow 11)
| M32 => 1 / (2 pow 24)
| M64 => 1 / (2 pow 53)
| F w f => 1 / (2 pow f)
(* the epsilons below match what is used internally in flover,
although these value do not match the IEEE standard *)
(* | M128 => 1 / (2 pow 105) *)
(* | M256 => 1 / (2 pow 211) *)`;
| F w f => 1 / (2 pow f)`;
val computeError_def = Define `
computeError v m =
......@@ -41,13 +40,13 @@ val computeError_def = Define `
| _ => abs v * mTypeToR m`;
val mTypeToR_pos = store_thm("mTypeToR_pos",
``!e. 0 <= mTypeToR e``,
``! e. 0 <= mTypeToR e``,
Cases_on `e` \\ TRY EVAL_TAC
\\ fs[]);
val computeError_up = store_thm (
"computeError_up",
``!v a b m.
``! v a b m.
abs v <= maxAbs (a,b) ==>
computeError v m <= computeError (maxAbs (a,b)) m``,
rpt strip_tac \\ Cases_on `m`
......@@ -65,8 +64,12 @@ val computeError_up = store_thm (
(**
Check if machine precision m1 is more precise than machine precision m2.
REAL is real-valued evaluation, hence the most precise.
All others are compared by
mTypeToR m1 <= mTypeToR m2
All floating-point types are compared by
mTypeToQ m1 <= mTypeToQ m2
All fixed-point types are compared by comparing only the word size
We consider a 32 bit fixed-point number to be more precise than a 16 bit
fixed-point number, no matter what the fractional bits may be.
For the moment, fixed-point and floating-point formats are incomparable.
**)
val isMorePrecise_def = Define `
isMorePrecise (m1:mType) (m2:mType) =
......@@ -77,6 +80,10 @@ val isMorePrecise_def = Define `
| _, F w f => F
| _, _ => (mTypeToR (m1) <= mTypeToR (m2))`;
(**
More efficient version for performance, unfortunately we cannot do better
for fixed-points
**)
val morePrecise_def = Define `
(morePrecise REAL _ = T) /\
(morePrecise (F w1 f1) (F w2 f2) = (w2 <= w1)) /\
......@@ -89,14 +96,6 @@ val morePrecise_def = Define `
(morePrecise M64 _ = T) /\
(morePrecise _ _ = F) `;
(* val morePrecise_antisym = store_thm ( *)
(* "morePrecise_antisym", *)
(* ``!m1 m2. *)
(* morePrecise m1 m2 /\ *)
(* morePrecise m2 m1 ==> *)
(* m1 = m2``, *)
(* rpt strip_tac \\ Cases_on `m1` \\ Cases_on `m2` \\ fs[morePrecise_def]); *)
val morePrecise_trans = store_thm (
"morePrecise_trans",
``!m1 m2 m3.
......@@ -123,15 +122,14 @@ val isMorePrecise_refl = store_thm (
val REAL_least_precision = store_thm ("REAL_least_precision",
``!(m:mType).
isMorePrecise m REAL ==>
m = REAL``,
fs [isMorePrecise_def, mTypeToR_def] \\
rpt strip_tac \\
Cases_on `m` \\
fs []);
isMorePrecise m REAL ==> m = REAL``,
fs [isMorePrecise_def, mTypeToR_def]
\\ rpt strip_tac
\\ Cases_on `m`
\\ fs []);
val REAL_lower_bound = store_thm ("REAL_lower_bound",
``! (m:mType).
``!(m:mType).
isMorePrecise REAL m``,
Cases_on `m` \\ EVAL_TAC);
......@@ -140,56 +138,55 @@ val REAL_lower_bound = store_thm ("REAL_lower_bound",
in which evaluation has to be performed, e.g. addition of 32 and 64 bit floats
has to happen in 64 bits
**)
val join_def = Define `
join (F w1 f1) (F w2 f2) (fBit:num) =
SOME (F (if w1 <= w2 then w2 else w1) fBit) /\
join (F w f) _ _ = NONE /\
join _ (F w f) _ = NONE /\
join (m1:mType) (m2:mType) (fBit:num) =
if (morePrecise m1 m2) then SOME m1 else SOME m2`;
val join_float = store_thm (
"join_float",
``!m1 m2 f1 f2.
isFixedPoint m1 = F /\
isFixedPoint m2 = F ==>
join m1 m2 f1 = join m1 m2 f2``,
rpt strip_tac \\ Cases_on `m1` \\ Cases_on `m2`
\\ fs[join_def, isFixedPoint_def] );
val join3_def = Define `
join3 (m1: mType) (m2: mType) (m3: mType) (fBit:num) =
case (join m2 m3) fBit of
| SOME m => join m1 m fBit
| NONE => NONE`
val join3_float = store_thm (
"join3_float",
``!m1 m2 m3 f1 f2.
isFixedPoint m1 = F /\
isFixedPoint m2 = F /\
isFixedPoint m3 = F ==>
join3 m1 m2 m3 f1 = join3 m1 m2 m3 f2``,
rpt strip_tac \\ Cases_on `m1` \\ Cases_on `m2` \\ Cases_on `m3`
\\ fs[join3_def, join_def, isFixedPoint_def, morePrecise_def]);
val join_fl_def = Define `
join_fl (F w1 f1) (F w2 f2) = NONE /\
join_fl m1 m2 = if (morePrecise m1 m2) then SOME m1 else SOME m2`;
val join_fl3_def = Define `
join_fl3 m1 m2 m3 =
do mj <- join_fl m1 m2; join_fl mj m3; od`;
(** Since we cannot compute a join for Fixed-Points, we give a
isJoin predicate which returns true for fixed-points, but needs to inspect
it for floating-points **)
val isCompat_def = Define `
isCompat (REAL) (REAL) = T /\
isCompat (F w1 f1) (F w2 f2) = morePrecise (F w1 f1) (F w2 f2) /\
isCompat (F _ _) _ = F /\
isCompat _ (F _ _) = F /\
isCompat m1 m2 = (m1 = m2)`;
val isJoin_def = Define `
isJoin m1 m2 mj =
if (isFixedPoint m1 /\ isFixedPoint m2)
then morePrecise m1 mj /\ morePrecise m2 mj
else
(case join_fl m1 m2 of
|NONE => F
|SOME mNew => mNew = mj) `;
val isJoin3_def = Define `
isJoin3 m1 m2 m3 mj =
if (isFixedPoint m1 /\ isFixedPoint m2 /\ isFixedPoint m3)
then morePrecise m1 mj /\ morePrecise m2 mj /\ morePrecise m3 mj
else
(case join_fl3 m1 m2 m3 of
|NONE => F
|SOME mNew => mNew = mj) `;
val maxExponent_def = Define `
(maxExponent (REAL) = 0n) /\
(maxExponent (M16) = 15) /\
(maxExponent (M32) = 127) /\
(maxExponent (M64) = 1023) /\
(maxExponent (F w f) = f)
(* | M128 => 1023 (** FIXME **) *)
(* | M256 => 1023 *)`;
(maxExponent (F w f) = f)`;
val minExponentPos_def = Define `
(minExponentPos (REAL) = 0n) /\
(minExponentPos (M16) = 14) /\
(minExponentPos (M32) = 126) /\
(minExponentPos (M64) = 1022) /\
(minExponentPos (F w f) = f) (*/\ *)
(* (minExponentPos (M128) = 1022) /\ (* FIXME *) *)
(* (minExponentPos (M256) = 1022) *)`;
(minExponentPos (F w f) = f)`;
(**
Goldberg - Handbook of Floating-Point Arithmetic: (p.183)
......
structure ResultsLib =
struct
open monadsyntax;
open ResultsTheory;
val res_monad = declare_monad ("Results",
{bind = ``result_bind``,
ignorebind = SOME ``result_ignore_bind``,
unit = ``result_return``,
fail = NONE, choice = NONE, guard = NONE});
val _ = monadsyntax.enable_monadsyntax();
val _ = List.app monadsyntax.enable_monad ["option", "Results"];
end
open stringTheory;
open preamble;
val _ = new_theory "Results";
val _ = Datatype `
result = Succes 'a | Fail string | FailDet string 'a`;
val injectResult_def = Define `
injectResult (Succes _) = T /\
injectResult _ = F`;
val result_bind_def = Define `
result_bind (Fail s) f = Fail s /\
result_bind (FailDet s x) f = FailDet s x /\
result_bind (Succes x) f = f x`;
val result_ignore_bind_def = Define `
result_ignore_bind m1 m2 = result_bind m1 (K m2) `;
val result_return_def = Define `
result_return x = Succes x`;
val _ = export_rewrites ["result_return_def", "result_bind_def", "result_ignore_bind_def"]
val _ = export_theory();
......@@ -6,10 +6,11 @@
The function is used in CertificateChecker.v to build the full checker.
**)
open simpLib realTheory realLib RealArith pred_setTheory sptreeTheory
sptreeLib;
open AbbrevsTheory ExpressionsTheory RealSimpsTheory FloverTactics
ExpressionAbbrevsTheory IntervalArithTheory CommandsTheory ssaPrgsTheory MachineTypeTheory
sptreeLib sptreeTheory FloverMapTheory
open preamble
ExpressionAbbrevsTheory IntervalArithTheory CommandsTheory ssaPrgsTheory
MachineTypeTheory FloverMapTheory TypeValidatorTheory;
open preamble;
val _ = new_theory "IntervalValidation";
......@@ -82,7 +83,8 @@ val validIntervalbounds_def = Define `
validIntervalbounds f2 absenv P validVars /\
validIntervalbounds f3 absenv P validVars)
then
case FloverMapTree_find f1 absenv, FloverMapTree_find f2 absenv, FloverMapTree_find f3 absenv of
case FloverMapTree_find f1 absenv, FloverMapTree_find f2 absenv,
FloverMapTree_find f3 absenv of
| SOME (iv1, _), SOME (iv2, _), SOME (iv3, _) =>
let new_iv = addInterval iv1 (multInterval iv2 iv3) in
isSupersetInterval new_iv intv
......@@ -122,19 +124,14 @@ val fVars_P_sound_def = Define `
?vR. E v = SOME vR /\
FST (P v) <= vR /\ vR <= SND (P v)`;
val vars_typed_def = Define `
vars_typed (S:num set) (Gamma:num -> mType option) =
!v. v IN S ==>
?m. Gamma v = SOME m`;
val cond_simpl = store_thm (
"cond_simpl[simp]",
``!a b. (if a then T else b) <=> (a \/ (~ a /\ b))``,
rpt strip_tac \\ metis_tac[]);
val validIntervalbounds_sound = store_thm ("validIntervalbounds_sound",
``!(f:real expr) (A:analysisResult) (P:precond) (fVars:num_set) (dVars:num_set)
E Gamma fBits.
``!(f:real expr) (A:analysisResult) (P:precond) (fVars:num_set)
(dVars:num_set) E Gamma.
validIntervalbounds f A P dVars /\ (* The checker succeeded *)
(* All defined vars have already been analyzed *)
dVars_range_valid dVars E A /\
......@@ -332,10 +329,6 @@ val validIntervalbounds_sound = store_thm ("validIntervalbounds_sound",
\\ `SND iv = SND intv` by (metis_tac [REAL_LE_ANTISYM])
\\ fs[]));
val getRetExp_def = Define `
(getRetExp (Let m x e g) = getRetExp g) /\
(getRetExp (Ret e) = e)`;
val Rmap_updVars_comm = store_thm (
"Rmap_updVars_comm",
``!Gamma n m x.
......
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment