Commit 5dbe22dc authored by Heiko Becker's avatar Heiko Becker

fforward CakeML to master branch, fforward HOL

parent 46d9b0cc
[submodule "hol4/cakeml"]
branch = FMA_support
branch = master
path = hol4/cakeml
url = https://github.com/CakeML/cakeml.git
......
8e183cc626814e8bfbee46abcbf51798ee1c69b6
570cfc9afd5e6ac1fd5a51e50c0780453c975124
......@@ -107,6 +107,9 @@ val validErrorbound_def = Define `
else F)`;
add_unevaluated_function ``validErrorbound``;
add_unevaluated_function ``minAbsFun``;
add_unevaluated_function ``noDivzero``;
val validErrorboundCmd_def = Define `
validErrorboundCmd (f:real cmd) (typeMap: (real expr # mType) binTree)
......@@ -167,6 +170,9 @@ val validErrorboundCorrectVariable_eval = store_thm (
>- (Cases_on `lookup v dVars` \\ fs[domain_lookup])
\\ fs[eval_expr_cases, toRExpMap_def, toRTMap_def, option_case_eq]);
add_unevaluated_function ``computeError``;
add_unevaluated_function ``maxAbs``;
val validErrorboundCorrectVariable = store_thm (
"validErrorboundCorrectVariable",
``! (E1 E2:env) A fVars dVars (v:num) (nR nF err nlo nhi:real) (P:precond) m
......@@ -290,7 +296,7 @@ val validErrorboundCorrectAddition = store_thm (
\\ qexists_tac `nR2` \\ conj_tac
\\ simp[contained_def])
\\ assume_tac (REWRITE_RULE [validIntervalAdd_def, contained_def] interval_addition_valid)
\\ fs[contained_def]);
\\ fs[contained_def, widenInterval_def]);
val validErrorboundCorrectSubtraction = store_thm ("validErrorboundCorrectSubtraction",
``!(E1 E2:env) (A:analysisResult) (e1:real expr) (e2:real expr)
......@@ -337,7 +343,7 @@ val validErrorboundCorrectSubtraction = store_thm ("validErrorboundCorrectSubtra
\\ qexists_tac `nR2` \\ conj_tac
\\ simp[contained_def])
\\ assume_tac (REWRITE_RULE [validIntervalSub_def, contained_def] interval_subtraction_valid)
\\ fs[contained_def]);
\\ fs[contained_def, widenInterval_def]);
val multiplicationErroBounded = store_thm ("multiplicationErrorBounded",
``!(nR1 nR2 nF1 nF2: real) (err1 err2: real) (e1lo e1hi e2lo e2hi: real).
......@@ -985,7 +991,7 @@ val validErrorboundCorrectMult = store_thm ("validErrorboundCorrectMult",
\\ qexists_tac `nR2` \\ conj_tac
\\ simp[contained_def])
\\ assume_tac (REWRITE_RULE [contained_def] interval_multiplication_valid)
\\ fs[contained_def]);
\\ fs[contained_def, widenInterval_def]);
val divisionErrorBounded = store_thm (
"divisionErrorBounded",
......@@ -2092,13 +2098,14 @@ val validErrorboundCorrectDiv = store_thm ("validErrorboundCorrectDiv",
\\ qexists_tac `nR2` \\ conj_tac
\\ simp[contained_def])
\\ irule REAL_LE_ADD2 \\ conj_tac
>- (irule divisionErrorBounded \\ fs[])
>- (irule (REWRITE_RULE [IVlo_def, IVhi_def, widenInterval_def, invertInterval_def] divisionErrorBounded)
\\ fs[widenInterval_def])
\\ qmatch_abbrev_tac `_ <= computeError (maxAbs iv) _`
\\ PairCases_on `iv` \\ irule computeError_up
\\ unabbrev_all_tac \\ fs[maxAbs_def]
\\ match_mp_tac maxAbs
\\ assume_tac (REWRITE_RULE [contained_def] interval_division_valid)
\\ fs[contained_def, noDivzero_def]);
\\ fs[contained_def, widenInterval_def, noDivzero_def]);
val validErrorboundCorrectFma = store_thm ("validErrorboundCorrectFma",
``!(E1 E2:env) (A:analysisResult) (e1:real expr) (e2:real expr) (e3: real expr)
......@@ -2176,7 +2183,7 @@ val validErrorboundCorrectFma = store_thm ("validErrorboundCorrectFma",
\\ unabbrev_all_tac \\ fs[maxAbs_def]
\\ match_mp_tac maxAbs
\\ assume_tac (REWRITE_RULE [validIntervalAdd_def, contained_def] interval_addition_valid)
\\ fs[contained_def, IVlo_def, IVhi_def, noDivzero_def]);
\\ fs[contained_def, widenInterval_def, IVlo_def, IVhi_def, noDivzero_def]);
val validErrorboundCorrectRounding = store_thm ("validErrorboundCorrectRounding",
``!(E1 E2:env) (A:analysisResult) (e:real expr)
......@@ -2207,8 +2214,10 @@ val validErrorboundCorrectRounding = store_thm ("validErrorboundCorrectRounding"
\\ unabbrev_all_tac \\ fs[maxAbs_def]
\\ match_mp_tac maxAbs
\\ assume_tac (REWRITE_RULE [contained_def] distance_gives_iv)
\\ fs[] \\ first_x_assum irule
\\ find_exists_tac \\ fs[]);
\\ fs[widenInterval_def]
\\ res_tac
\\ ntac 2 (first_x_assum (qspec_then `(elo, ehi)` assume_tac))
\\ rpt (first_x_assum (destruct) \\ fs[]));
(**
Soundness theorem for the error bound validator.
......@@ -2381,7 +2390,7 @@ val validErrorbound_sound = store_thm ("validErrorbound_sound",
\\ TRY (irule Binop_dist'
\\ qexistsl_tac [`0`, `REAL`, `REAL`, `REAL`, `v1`, `v2`]
\\ fs[perturb_def, mTypeToR_pos])
\\ simp[Once validErrorbound_def])
\\ simp[Once validErrorbound_def, widenInterval_def, invertInterval_def])
>- (rename1 `Fma e1 e2 e3` \\ fs[]
\\ Flover_compute ``validErrorbound``
\\ rveq \\ fs[toREval_def]
......@@ -2493,7 +2502,7 @@ val validErrorbound_sound = store_thm ("validErrorbound_sound",
\\ irule Fma_dist'
\\ qexistsl_tac [`0`, `REAL`, `REAL`, `REAL`, `REAL`, `nR1`, `nR2`, `nR3`]
\\ fs[perturb_def, mTypeToR_pos])
\\ once_rewrite_tac [validErrorbound_def] \\ fs[])
\\ once_rewrite_tac [validErrorbound_def] \\ fs[widenInterval_def])
>- (rename1 `Downcast m1 e1` \\ fs[]
\\ Flover_compute ``validErrorbound``
\\ rveq \\ fs[toREval_def]
......@@ -2533,7 +2542,7 @@ val validErrorbound_sound = store_thm ("validErrorbound_sound",
\\ fs[]
\\ rpt conj_tac
>- (first_x_assum irule \\ asm_exists_tac \\ fs[])
>- (once_rewrite_tac [validErrorbound_def] \\ fs[])
>- (once_rewrite_tac [validErrorbound_def] \\ fs[widenInterval_def])
\\ irule Downcast_dist' \\ fs[updDefVars_def]
\\ find_exists_tac \\ fs[]
\\ qexistsl_tac [`delta`, `v1`]
......
......@@ -251,7 +251,7 @@ val binary_unfolding = store_thm("binary_unfolding",
(Binop b (Var 1) (Var 2)) (perturb (evalBinop b v1 v2) m delta) m``,
fs [updEnv_def,updDefVars_def,join_fl_def,eval_expr_cases,APPLY_UPDATE_THM,PULL_EXISTS]
\\ rpt strip_tac
\\ qexists_tac `delta'` \\ fs[]
\\ qexists_tac `delta` \\ fs[]
\\ IMP_RES_TAC Gamma_det \\ fs[]);
val fma_unfolding = store_thm("fma_unfolding",
......@@ -268,7 +268,7 @@ val fma_unfolding = store_thm("fma_unfolding",
(Fma (Var 1) (Var 2) (Var 3)) (perturb (evalFma v1 v2 v3) m delta) m``,
fs [updEnv_def,updDefVars_def,join_fl3_def,join_fl_def,eval_expr_cases,APPLY_UPDATE_THM,PULL_EXISTS]
\\ rpt strip_tac
\\ qexists_tac `delta'` \\ fs[]
\\ qexists_tac `delta` \\ fs[]
\\ IMP_RES_TAC Gamma_det \\ fs[]);
val eval_eq_env = store_thm (
......@@ -280,17 +280,17 @@ val eval_eq_env = store_thm (
Induct \\ rpt strip_tac \\ fs[eval_expr_cases]
>- (`E1 n = E2 n` by (first_x_assum irule)
\\ fs[])
>- (qexists_tac `delta'` \\ fs[])
>- (qexists_tac `delta` \\ fs[])
>- (rveq \\ qexistsl_tac [`m'`, `v1`] \\ fs[]
\\ first_x_assum drule \\ disch_then irule \\ fs[])
>- (rveq \\ qexistsl_tac [`m'`, `v1`] \\ fs[]
\\ qexists_tac `delta'` \\ fs[]
\\ qexists_tac `delta` \\ fs[]
\\ first_x_assum drule \\ disch_then irule \\ fs[])
>- (rveq \\ qexistsl_tac [`m1`, `m2`, `v1`, `v2`, `delta'`]
>- (rveq \\ qexistsl_tac [`m1`, `m2`, `v1`, `v2`, `delta`]
\\ fs[] \\ conj_tac \\ first_x_assum irule \\ asm_exists_tac \\ fs[])
>- (rveq \\ qexistsl_tac [`m1`, `m2`, `m3`, `v1`, `v2`, `v3`, `delta'`]
>- (rveq \\ qexistsl_tac [`m1`, `m2`, `m3`, `v1`, `v2`, `v3`, `delta`]
\\ fs[] \\ prove_tac [])
>- (rveq \\ qexistsl_tac [`m1'`, `v1`, `delta'`] \\ fs[]
>- (rveq \\ qexistsl_tac [`m1'`, `v1`, `delta`] \\ fs[]
\\ first_x_assum drule \\ disch_then irule \\ fs[]));
val swap_Gamma_eval_expr = store_thm (
......
INCLUDES = $(HOLDIR)/examples/machine-code/hoare-triple Infra cakeml/translator cakeml/basis cakeml/characteristic cakeml/misc
OPTIONS = QUIT_ON_FAILURE
ifdef POLY
HOLHEAP = heap
EXTRA_CLEANS = $(HOLHEAP) $(HOLHEAP).o
all: $(HOLHEAP)
THYFILES = $(patsubst %Script.sml,%Theory.uo,$(wildcard *.sml))
TARGETS0 = $(patsubst %Theory.sml,,$(THYFILES))
TARGETS = $(patsubst %.sml,%.uo,$(TARGETS0))
all: $(TARGETS) $(HOLHEAP)
.PHONY: all
BARE_THYS = BasicProvers Defn HolKernel Parse Tactic monadsyntax \
alistTheory arithmeticTheory bagTheory boolLib boolSimps bossLib \
combinTheory dep_rewrite finite_mapTheory indexedListsTheory lcsymtacs \
listTheory llistTheory markerLib realTheory realLib RealArith\
optionTheory pairLib pairTheory pred_setTheory \
quantHeuristicsLib relationTheory res_quanTheory rich_listTheory \
sortingTheory sptreeTheory stringTheory sumTheory wordsTheory \
simpLib realTheory realLib RealArith \
cakeml/translator/ml_translatorLib \
cakeml/basis/basis_ffiLib
DEPS = $(patsubst %,%.uo,$(BARE_THYS1)) $(PARENTHEAP)
$(HOLHEAP): $(DEPS)
$(protect $(HOLDIR)/bin/buildheap) -o $(HOLHEAP) $(BARE_THYS)
endif
#ifdef POLY
#HOLHEAP = heap
#EXTRA_CLEANS = $(HOLHEAP) $(HOLHEAP).o
#all: $(HOLHEAP)
#
#THYFILES = $(patsubst %Script.sml,%Theory.uo,$(wildcard *.sml))
#TARGETS0 = $(patsubst %Theory.sml,,$(THYFILES))
#TARGETS = $(patsubst %.sml,%.uo,$(TARGETS0))
#
#all: $(TARGETS) $(HOLHEAP)
#
#.PHONY: all
#
#BARE_THYS = BasicProvers Defn HolKernel Parse Tactic monadsyntax \
# alistTheory arithmeticTheory bagTheory boolLib boolSimps bossLib \
# combinTheory dep_rewrite finite_mapTheory indexedListsTheory lcsymtacs \
# listTheory llistTheory markerLib realTheory realLib RealArith\
# optionTheory pairLib pairTheory pred_setTheory \
# quantHeuristicsLib relationTheory res_quanTheory rich_listTheory \
# sortingTheory sptreeTheory stringTheory sumTheory wordsTheory \
# simpLib realTheory realLib RealArith \
# cakeml/translator/ml_translatorLib \
# cakeml/basis/basis_ffiLib
#
#DEPS = $(patsubst %,%.uo,$(BARE_THYS1)) $(PARENTHEAP)
#
#$(HOLHEAP): $(DEPS)
# $(protect $(HOLDIR)/bin/buildheap) -o $(HOLHEAP) $(BARE_THYS)
#endif
This diff is collapsed.
......@@ -3,7 +3,7 @@
Used in soundness proofs for error bound validator.
**)
open realTheory realLib RealArith
open AbbrevsTheory ExpressionsTheory RealSimpsTheory;
open AbbrevsTheory ExpressionsTheory RealSimpsTheory FloverTactics;
open preamble
val _ = new_theory "IntervalArith";
......@@ -81,15 +81,23 @@ invertInterval (iv:interval) = (1 /(IVhi iv), 1 /(IVlo iv))`;
val addInterval_def = Define `
addInterval (iv1:interval) (iv2:interval) = absIntvUpd (+) iv1 iv2`;
add_unevaluated_function ``addInterval``;
val subtractInterval_def = Define `
subtractInterval (iv1:interval) (iv2:interval) = addInterval iv1 (negateInterval iv2)`;
add_unevaluated_function ``subtractInterval``;
val multInterval_def = Define `
multInterval (iv1:interval) (iv2:interval) = absIntvUpd ( * ) iv1 iv2`;
add_unevaluated_function ``multInterval``;
val divideInterval_def = Define `
divideInterval iv1 iv2 = multInterval iv1 (invertInterval iv2)`;
add_unevaluated_function ``divideInterval``;
val minAbsFun_def = Define `
minAbsFun iv = min (abs (FST iv)) (abs (SND iv))`;
......
......@@ -131,7 +131,7 @@ val validIntervalbounds_sound = store_thm ("validIntervalbounds_sound",
validTypes f Gamma ==>
validRanges f A E (toRTMap (toRExpMap Gamma))``,
Induct_on `f`
\\ once_rewrite_tac [usedVars_def, toREval_def] \\ rpt strip_tac
\\ once_rewrite_tac [usedVars_def, toREval_def] \\ rpt strip_tac \\ rveq
\\ Flover_compute ``validIntervalbounds`` \\ rveq
(* Defined variable case *)
>- (rw_thm_asm `dVars_range_valid _ _ _` dVars_range_valid_def
......@@ -233,7 +233,8 @@ val validIntervalbounds_sound = store_thm ("validIntervalbounds_sound",
addInterval_def,
absIntvUpd_def,
contained_def] interval_addition_valid)
\\ fs[] \\ real_prove)
\\ fs[] \\ res_tac
\\ real_prove)
(* Sub case *)
>- (fs[evalBinop_def, isSupersetInterval_def, absIntvUpd_def,
subtractInterval_def, addInterval_def, negateInterval_def]
......@@ -426,18 +427,18 @@ val validIntervalbounds_validates_iv = store_thm ("validIntervalbounds_validates
\\ irule REAL_LE_TRANS
\\ asm_exists_tac \\ fs[]
\\ irule REAL_LE_TRANS
\\ asm_exists_tac \\ fs[])
\\ find_exists_tac \\ fs[])
>- (`valid (invertInterval iv)`
by (irule iv_inv_preserves_valid \\ fs[])
\\ fs[valid_def, isSupersetInterval_def]
>- (irule REAL_LE_TRANS
\\ asm_exists_tac \\ fs[]
\\ irule REAL_LE_TRANS
\\ asm_exists_tac \\ fs[])
\\ find_exists_tac \\ fs[invertInterval_def])
\\ irule REAL_LE_TRANS
\\ asm_exists_tac \\ fs[]
\\ irule REAL_LE_TRANS
\\ asm_exists_tac \\ fs[]))
\\ find_exists_tac \\ fs[invertInterval_def]))
>- (rename1 `Binop b f1 f2`
\\ rpt (first_x_assum (qspecl_then [`A`, `P`, `dVars`] destruct) \\ fs[])
\\ rveq \\ fs[]
......
Subproject commit c158f1ade07e9eb7d2db9fc7e8d9faff8156452f
Subproject commit 52270c049337b1915a61c946c535e43a0d2084b5
......@@ -27,7 +27,7 @@ val getConst_def = Define `
getConst (c:char) = ORD c - 48`;
val lexConst_def = Define`
lexConst (input:tvarN) (akk:num) =
lexConst (input:string) (akk:num) =
case input of
| STRING char input' =>
if (isDigit char)
......@@ -36,7 +36,7 @@ val lexConst_def = Define`
|"" => (akk, input)`;
val lexName_def = Define `
lexName (input:tvarN) =
lexName (input:string) =
case input of
| STRING char input' =>
if (isAlphaNum char)
......
......@@ -447,9 +447,9 @@ val st = get_ml_prog_state()
the function to STDOUT *)
val main_spec = Q.store_thm("main_spec",
`hasFreeFD fs inFS_fname fs (File fname)
`hasFreeFD fs inFS_fname fs fname
cl = [pname; fname]
contents = lines_of (implode (THE (ALOOKUP fs.files (File fname)))) ==>
contents = all_lines fs fname ==>
app (p:'ffi ffi_proj) ^(fetch_v "main" st)
[uv] (STDIO fs * COMMANDLINE cl)
(POSTv uv. &UNIT_TYPE () uv *
......@@ -483,9 +483,9 @@ val main_spec = Q.store_thm("main_spec",
\\ fs[all_lines_def]);
val main_whole_prog_spec = Q.store_thm("main_whole_prog_spec",
`hasFreeFD fs /\ inFS_fname fs (File fname) /\
cl = [pname; fname] /\
contents = lines_of (implode (THE (ALOOKUP fs.files (File fname)))) ==>
`hasFreeFD fs inFS_fname fs fname
cl = [pname; fname]
contents = all_lines fs fname ==>
whole_prog_spec ^(fetch_v "main" st) cl fs NONE
((=) (add_stdout fs (runchecker_output_spec contents)))`,
disch_then assume_tac
......
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