617 lines
24 KiB
Standard ML
617 lines
24 KiB
Standard ML
(*
|
|
* Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
|
|
*
|
|
* SPDX-License-Identifier: BSD-2-Clause
|
|
*)
|
|
|
|
(*
|
|
* Lift monadic structures into lighter-weight monads.
|
|
*)
|
|
structure TypeStrengthen =
|
|
struct
|
|
|
|
exception AllLiftingFailed of (string * thm) list
|
|
exception LiftingFailed of unit
|
|
|
|
(* FIXME: use AUTOCORRES_SIMPSET (need to fix unknown deps of the corres prover) *)
|
|
val ts_simpset = simpset_of @{context}
|
|
|
|
(* Misc util functions. *)
|
|
val the' = Utils.the'
|
|
val apply_tac = Utils.apply_tac
|
|
|
|
fun get_l2_state_typ ctxt prog_info l2_infos fn_name =
|
|
let
|
|
val term = #const (the (Symtab.lookup l2_infos fn_name));
|
|
in
|
|
LocalVarExtract.dest_l2monad_T (fastype_of term) |> snd |> #1
|
|
end;
|
|
|
|
fun get_typ_from_L2 (rule_set : Monad_Types.monad_type) L2_typ =
|
|
LocalVarExtract.dest_l2monad_T L2_typ |> snd |> #typ_from_L2 rule_set
|
|
|
|
(*
|
|
* Make an equality prop of the form "L2_call <foo> = <liftE> $ <bar>".
|
|
*
|
|
* L2_call and <liftE> will typically be desired to be polymorphic in their
|
|
* exception type. We fix it to "unit"; the caller will need to introduce
|
|
* polymorphism as necessary.
|
|
*
|
|
* If "measure" is non-NONE, then that term will be used instead of a free
|
|
* variable.
|
|
* If "state_typ" is non-NONE, then "measure" is assumed to also take a
|
|
* state parameter of the given type.
|
|
*)
|
|
fun make_lift_equality ctxt prog_info l2_infos fn_name
|
|
(rule_set : Monad_Types.monad_type) state_typ measure rhs_term =
|
|
let
|
|
val thy = Proof_Context.theory_of ctxt
|
|
|
|
(* Fetch function variables. *)
|
|
val fn_def = the (Symtab.lookup l2_infos fn_name)
|
|
val inputs = #args fn_def
|
|
val input_vars = map (fn (x, y) => Var ((x, 0), y)) inputs
|
|
|
|
(*
|
|
* Measure var.
|
|
*
|
|
* The L2 left-hand-side will always use this measure, while the
|
|
* right-hand-side will only include a measure if the function is actually
|
|
* recursive.
|
|
*)
|
|
val is_recursive = FunctionInfo.is_function_recursive fn_def
|
|
val default_measure_var = @{term "rec_measure' :: nat"} (* FIXME: Free *)
|
|
val measure_term = Option.getOpt (measure, default_measure_var)
|
|
|
|
(*
|
|
* Construct the equality.
|
|
*
|
|
* This is a little delicate: in particular, we need to ensure that
|
|
* the type of the resulting term is strictly correct. In particular,
|
|
* our "lift_fn" will have type variables that need to be modified.
|
|
* "Utils.mk_term" will fill in type variables of the base term based
|
|
* on what is applied to it. So, we need to ensure that the lift
|
|
* function is in our base term, and that its type variables have the
|
|
* same names ("'s" for state, "'a" for return type) that we use
|
|
* below.
|
|
*)
|
|
(* FIXME: use @{mk_term} *)
|
|
val base_term = @{term "%L a b. (L2_call :: ('s, 'a, unit) L2_monad => ('s, 'a, unit) L2_monad) a = L b"}
|
|
val a = betapplys (#const fn_def, measure_term :: input_vars)
|
|
val b = if not is_recursive then betapplys (rhs_term, input_vars) else
|
|
case state_typ of
|
|
NONE => betapplys (rhs_term, measure_term :: input_vars)
|
|
| SOME s => betapplys (rhs_term, [measure_term] @ input_vars @ [Free ("s'", s)]) (* FIXME: Free *)
|
|
|> lambda (Free ("s'", s))
|
|
val term = Utils.mk_term thy (betapply (base_term, #L2_call_lift rule_set)) [a, b]
|
|
|> HOLogic.mk_Trueprop
|
|
|
|
in
|
|
(* Convert it into a trueprop with meta-foralls. *)
|
|
Utils.vars_to_metaforall term
|
|
end
|
|
|
|
(*
|
|
* Assume recursively called functions correctly map into the given type.
|
|
*
|
|
* We return:
|
|
*
|
|
* (<newly generated context>,
|
|
* <the measure variable used>,
|
|
* <generated assumptions>,
|
|
* <table mapping free term names back to their function names>,
|
|
* <morphism to escape the context>)
|
|
*
|
|
* FIXME: refactor with AutoCorresUtil.assume_called_functions_corres
|
|
*)
|
|
fun assume_rec_lifted ctxt prog_info l2_infos rule_set fn_name =
|
|
let
|
|
val fn_def = the (Symtab.lookup l2_infos fn_name)
|
|
|
|
(* Find recursive calls. *)
|
|
val recursive_calls = Symset.dest (#rec_callees fn_def)
|
|
|
|
(* Fix a variable for each such call, plus another for our measure variable. *)
|
|
val (measure_fix :: dest_fn_fixes, ctxt')
|
|
= Variable.add_fixes ("rec_measure'" :: map (fn x => "rec'" ^ x) recursive_calls) ctxt
|
|
val rec_fun_names = Symtab.make (dest_fn_fixes ~~ recursive_calls)
|
|
|
|
(* For recursive calls, we need a term representing our measure variable and
|
|
* another representing our decremented measure variable. *)
|
|
val measure_var = Free (measure_fix, @{typ nat})
|
|
val dec_measure_var = @{const "recguard_dec"} $ measure_var
|
|
|
|
(* For each recursive call, generate a theorem assuming that it lifts into
|
|
* the type/monad of "rule_set". *)
|
|
val dest_fn_thms = map (fn (callee, var) =>
|
|
let
|
|
val fn_def' = the (Symtab.lookup l2_infos callee)
|
|
val inputs = #args fn_def'
|
|
val T = (@{typ nat} :: map snd inputs)
|
|
---> (fastype_of (#const fn_def') |> get_typ_from_L2 rule_set)
|
|
|
|
(* NB: pure functions would not use state, but recursive functions cannot
|
|
* be lifted to pure (because we trigger failure when the measure hits
|
|
* 0). So we can always assume there is state. *)
|
|
val state_typ = get_l2_state_typ ctxt prog_info l2_infos fn_name
|
|
val x = make_lift_equality ctxt prog_info l2_infos callee rule_set
|
|
(SOME state_typ) (SOME dec_measure_var) (Free (var, T))
|
|
in
|
|
Thm.cterm_of ctxt' x
|
|
end) (recursive_calls ~~ dest_fn_fixes)
|
|
(* Our measure does not type-check for pure functions,
|
|
causing a TERM exception from mk_term. *)
|
|
handle TERM _ => raise LiftingFailed ()
|
|
|
|
(* Assume the theorems we just generated. *)
|
|
val (thms, ctxt'') = Assumption.add_assumes dest_fn_thms ctxt'
|
|
val thms = map (fn t => (#polymorphic_thm rule_set) OF [t]) thms
|
|
in
|
|
(ctxt'',
|
|
measure_var,
|
|
thms,
|
|
rec_fun_names,
|
|
Assumption.export_morphism ctxt'' ctxt'
|
|
$> Variable.export_morphism ctxt' ctxt)
|
|
end
|
|
|
|
|
|
(*
|
|
* Given a function definition, attempt to lift it into a different
|
|
* monadic structure by applying a set of rewrite rules.
|
|
*
|
|
* For example, given:
|
|
*
|
|
* foo x y = doE
|
|
* a <- returnOk 3;
|
|
* b <- returnOk 5;
|
|
* returnOk (a + b)
|
|
* odE
|
|
*
|
|
* we may be able to lift to:
|
|
*
|
|
* foo x y = returnOk (let
|
|
* a = 3;
|
|
* b = 5;
|
|
* in
|
|
* a + b)
|
|
*
|
|
* This second function has the form "lift $ term" for some lifting function
|
|
* "lift" and some new term "term". (These would be "returnOk" and "let a = ...
|
|
* in a + b" in the example above, respectively.)
|
|
*
|
|
* We return a theorem of the form "foo x y == <lift> $ <term>", along with the
|
|
* new term "<term>". If the lift was unsuccessful, we return "NONE".
|
|
*)
|
|
fun perform_lift ctxt prog_info l2_infos rule_set fn_name =
|
|
let
|
|
(* Assume recursive calls can be successfully lifted into this type. *)
|
|
val (ctxt', measure_var, thms, dict, m)
|
|
= assume_rec_lifted ctxt prog_info l2_infos rule_set fn_name
|
|
|
|
val fn_def = #definition (the (Symtab.lookup l2_infos fn_name))
|
|
|
|
(* Extract the term from our function definition. *)
|
|
val fn_thm' = Utils.named_cterm_instantiate ctxt
|
|
[("rec_measure'" (* FIXME *), Thm.cterm_of ctxt' measure_var)] fn_def
|
|
handle THM _ => fn_def
|
|
val ct = Thm.prop_of fn_thm' |> Utils.rhs_of |> Thm.cterm_of ctxt'
|
|
|
|
(* Rewrite the term using the given rewrite rules. *)
|
|
val t = Thm.term_of ct
|
|
val thm = case Monad_Convert.monad_rewrite ctxt rule_set thms true t of
|
|
SOME t => t
|
|
| NONE => Utils.named_cterm_instantiate ctxt [("x", ct)] @{thm reflexive}
|
|
|
|
(* Convert "def == old_body" and "old_body == new_body" into "def == new_body". *)
|
|
val thm_ml = Thm.transitive fn_thm' thm
|
|
|
|
(* Get the newly rewritten term. *)
|
|
val new_term = Thm.concl_of thm_ml |> Utils.rhs_of
|
|
|
|
(* Export assumptions, converting callees to schematics. *)
|
|
val thm_ml = Morphism.thm m thm_ml
|
|
|
|
(*val _ = @{trace} (fn_name, #name rule_set, cterm_of (Proof_Context.theory_of ctxt) new_term)*)
|
|
|
|
(* Determine if the conversion was successful. *)
|
|
val success = #valid_term rule_set ctxt new_term
|
|
in
|
|
(* Determine if the lifting succeeded. *)
|
|
if success then
|
|
SOME (thm_ml, dict)
|
|
else
|
|
NONE
|
|
end
|
|
|
|
(* Like perform_lift, but also applies the polishing rules, hopefully yielding
|
|
* an even nicer definition. *)
|
|
fun perform_lift_and_polish ctxt prog_info fn_info rule_set do_opt fn_name =
|
|
case (perform_lift ctxt prog_info fn_info rule_set fn_name)
|
|
of NONE => NONE
|
|
| SOME (thm, dict) => SOME let
|
|
|
|
(* Apply any polishing rules. *)
|
|
val polish_thm = Monad_Convert.polish ctxt rule_set do_opt thm
|
|
|
|
in (polish_thm, dict) end
|
|
|
|
|
|
(*
|
|
* Attempt to lift a function (or recursive function group) into the given monad.
|
|
*
|
|
* If successful, we define the new function (vis. group) to the theory.
|
|
* We then return a theorem of the form:
|
|
*
|
|
* "L2_call foo x y z == <lift> $ new_foo x y z"
|
|
*
|
|
* where "lift" is a lifting function, such as "returnOk" or "gets", etc.
|
|
*
|
|
* If the lift does not succeed, the function returns NONE.
|
|
*
|
|
* The callees of this function need to be already translated in ts_infos
|
|
* and also defined in lthy.
|
|
*)
|
|
fun lift_function_rewrite rule_set filename prog_info l2_infos ts_infos
|
|
fn_names make_function_name keep_going do_opt lthy =
|
|
let
|
|
val these_l2_infos = map (the o Symtab.lookup l2_infos) fn_names
|
|
|
|
(* Determine if this function is recursive. *)
|
|
val is_recursive = FunctionInfo.is_function_recursive (hd these_l2_infos)
|
|
|
|
(* Fetch relevant callees. *)
|
|
val callees =
|
|
map #callees these_l2_infos
|
|
|> Symset.union_sets
|
|
|> Symset.dest
|
|
val callee_infos = map (Symtab.lookup ts_infos #> the) callees
|
|
|
|
(* Add monad_mono theorems. *)
|
|
val callee_l2_infos = map (Symtab.lookup l2_infos #> the) callees
|
|
val mono_thms = List.mapPartial #mono_thm callee_l2_infos
|
|
|
|
(* When lifting, also lift our callees. *)
|
|
val rule_set' = Monad_Types.update_mt_lift_rules
|
|
(fn thms => Monad_Types.thmset_adds thms (map #corres_thm callee_infos @ mono_thms))
|
|
rule_set
|
|
|
|
(*
|
|
* Attempt to lift all functions into this type.
|
|
*
|
|
* For mutually recursive functions, every function in the group needs to be
|
|
* lifted in the same type.
|
|
*
|
|
* Eliminate the "SOME", raising an exception if any function in the group
|
|
* couldn't be lifted to this type.
|
|
*)
|
|
val lifted_functions =
|
|
map (perform_lift_and_polish lthy prog_info l2_infos rule_set' do_opt) fn_names
|
|
|
|
val lifted_functions = map (fn x =>
|
|
case x of
|
|
SOME a => a
|
|
| NONE => raise LiftingFailed ())
|
|
lifted_functions
|
|
val thms = map fst lifted_functions
|
|
val dicts = map snd lifted_functions
|
|
|
|
(*
|
|
* Generate terms necessary for defining the function, and define the
|
|
* functions.
|
|
*)
|
|
fun gen_fun_def_term (fn_name, dict, thm) lthy =
|
|
let
|
|
(* Fix function parameters. *)
|
|
val fn_info = the (Symtab.lookup l2_infos fn_name)
|
|
(* Only produce measure parameters for recursive functions. *)
|
|
val all_arg_names = (if is_recursive then ["rec_measure'"] else []) @
|
|
map fst (#args fn_info)
|
|
val all_arg_types = (if is_recursive then [AutoCorresUtil.measureT] else []) @
|
|
map snd (#args fn_info)
|
|
val (all_arg_names, lthy') = Variable.variant_fixes all_arg_names lthy
|
|
val (measure_param, fn_args) =
|
|
if is_recursive
|
|
then chop 1 (all_arg_names ~~ all_arg_types)
|
|
else ([], all_arg_names ~~ all_arg_types)
|
|
|
|
(* Extract function body and abstract over the function arguments.
|
|
* FIXME: this is an ugly way to do it. It's probably better if perform_lift
|
|
* doesn't convert to schematic vars to begin with *)
|
|
|
|
(* First, convert schematic argument variables (of unknown names) to known free variables. *)
|
|
val inst_args = map (Free #> Thm.cterm_of lthy' #> SOME) fn_args
|
|
(* L2 function always takes a measure variable, so reserve a slot *)
|
|
val inst_measure = if is_recursive
|
|
then map (Free #> Thm.cterm_of lthy' #> SOME) measure_param else [NONE]
|
|
(* thm also has a schematic const for each recursive assumption,
|
|
* which we need to skip. (The measure var appears first, because it
|
|
* is also used in each recursive call.) *)
|
|
val skip_callees = replicate (Symset.card (#rec_callees fn_info)) NONE
|
|
val inst_thm = Drule.infer_instantiate' lthy' (inst_measure @ skip_callees @ inst_args) thm
|
|
|
|
(* Extract the body from the conversion theorem.
|
|
* E.g. for "L2_call foo = liftE body" we extract "body". *)
|
|
fun tail_of (_ $ x) = x
|
|
val body =
|
|
Thm.concl_of inst_thm
|
|
|> Utils.rhs_of_eq
|
|
|> tail_of
|
|
(* This converts callee Vars in assumptions to Frees. Won't be
|
|
* necessary if we generate Frees (see previous FIXME). *)
|
|
|> Utils.unsafe_unvarify
|
|
(* Abstract over args, which are now known arg frees *)
|
|
val term = foldr (fn (v, t) => Utils.abs_over "" v t)
|
|
body (map Free (measure_param @ fn_args))
|
|
|
|
(* Replace place-holder function names with our generated constant name. *)
|
|
val term = map_aterms (fn t => case t of
|
|
Free (n, T) =>
|
|
(case Symtab.lookup dict n of
|
|
NONE => t
|
|
| SOME a => Free (make_function_name a, T))
|
|
| x => x) term
|
|
in
|
|
((make_function_name fn_name, measure_param @ fn_args, term), lthy')
|
|
end
|
|
(* NB: discard lthy because we don't want the placeholders to be fixed during define_functions *)
|
|
val (input_defs, _) = fold_map gen_fun_def_term (Utils.zip3 fn_names dicts thms) lthy
|
|
val (ts_defs, lthy) = Utils.define_functions input_defs false is_recursive lthy
|
|
(* TODO: we may want to cleanup callees and rec_callees here, like we do
|
|
* in other phases. It's not crucial, however, since this is the
|
|
* final phase. *)
|
|
|
|
(* Instantiate variables in our equivalence theorem to their newly-defined values. *)
|
|
fun do_inst_thm thm =
|
|
Utils.instantiate_thm_vars lthy (
|
|
fn ((name, _), t) =>
|
|
try (unprefix "rec'") name
|
|
(* FIXME: lookup from ts_infos *)
|
|
|> Option.map make_function_name
|
|
|> Option.map (Utils.get_term lthy)
|
|
|> Option.map (Thm.cterm_of lthy)) thm
|
|
val inst_thms = map do_inst_thm thms
|
|
|
|
(* HACK: If an L2 function takes no parameters, its measure gets eta-contracted
|
|
away, preventing eqsubst_tac from unifying the rec_measure's schematic
|
|
variable. So we get rid of the schematic var pre-emptively. *)
|
|
val inst_thms =
|
|
map (fn inst_thm => Drule.abs_def inst_thm handle TERM _ => inst_thm) inst_thms
|
|
|
|
(* Generate a theorem converting "L2_call <func>" into its new form,
|
|
* such as L2_call <func> = liftE $ <new_func_def> *)
|
|
val final_props = map (fn fn_name =>
|
|
make_lift_equality lthy prog_info l2_infos fn_name rule_set'
|
|
NONE NONE (Utils.get_term lthy (make_function_name fn_name))) fn_names
|
|
|
|
(* Convert meta-logic into HOL statements, conjunct them together and setup
|
|
* our goal statement. *)
|
|
val int_props = map (Object_Logic.atomize_term lthy) final_props
|
|
val goal = Utils.mk_conj_list int_props
|
|
|> HOLogic.mk_Trueprop
|
|
|> Thm.cterm_of lthy
|
|
|
|
val simps =
|
|
#L2_simp_rules rule_set' @
|
|
@{thms gets_bind_ign L2_call_fail HOL.simp_thms}
|
|
|
|
val rewrite_thm =
|
|
Goal.init goal
|
|
|> (fn goal_state => if is_recursive then
|
|
goal_state
|
|
|> apply_tac "start induction"
|
|
(resolve_tac lthy @{thms recguard_induct} 1)
|
|
|> apply_tac "(base case) split subgoals"
|
|
(TRY (REPEAT_ALL_NEW (Tactic.match_tac lthy [@{thm conjI}]) 1))
|
|
|> apply_tac "(base case) solve base cases"
|
|
(EVERY (map (fn (ts_def, l2_info) =>
|
|
SOLVES (
|
|
(EqSubst.eqsubst_tac lthy [0] [#definition l2_info] 1)
|
|
THEN (EqSubst.eqsubst_tac lthy [0] [ts_def] 1)
|
|
THEN (simp_tac (put_simpset ts_simpset lthy) 1))) (ts_defs ~~ these_l2_infos)))
|
|
|> apply_tac "(rec case) spliting induct case prems"
|
|
(TRY (REPEAT_ALL_NEW (Tactic.ematch_tac lthy [@{thm conjE}]) 1))
|
|
|> apply_tac "(rec case) split inductive case subgoals"
|
|
(TRY (REPEAT_ALL_NEW (Tactic.match_tac lthy [@{thm conjI}]) 1))
|
|
|> apply_tac "(rec case) unfolding strengthened function definition"
|
|
(EVERY (map (fn (def, inst_thm) =>
|
|
((EqSubst.eqsubst_tac lthy [0] [def] 1)
|
|
THEN (EqSubst.eqsubst_tac lthy [0] [inst_thm] 1)
|
|
THEN (REPEAT (CHANGED (asm_full_simp_tac (put_simpset ts_simpset lthy) 1)))))
|
|
(ts_defs ~~ inst_thms)))
|
|
else
|
|
goal_state
|
|
|> apply_tac "unfolding strengthen function definition"
|
|
(EqSubst.eqsubst_tac lthy [0] [hd ts_defs] 1)
|
|
|> apply_tac "unfolding L2 rewritten theorem"
|
|
(EqSubst.eqsubst_tac lthy [0] [hd inst_thms] 1)
|
|
|> apply_tac "simplifying remainder"
|
|
(TRY (simp_tac (put_simpset HOL_ss (Utils.set_hidden_ctxt lthy) addsimps simps) 1))
|
|
)
|
|
|> Goal.finish lthy
|
|
|
|
(* Now, using this combined theorem, generate a theorem for each individual
|
|
* function. *)
|
|
fun prove_partial_pred thm pred =
|
|
Thm.cterm_of lthy pred
|
|
|> Goal.init
|
|
|> apply_tac "inserting hypothesis"
|
|
(cut_tac thm 1)
|
|
|> apply_tac "normalising into rule format"
|
|
((REPEAT (resolve_tac lthy @{thms allI} 1))
|
|
THEN (REPEAT (eresolve_tac lthy @{thms conjE} 1))
|
|
THEN (REPEAT (eresolve_tac lthy @{thms allE} 1)))
|
|
|> apply_tac "solving goal" (assume_tac lthy 1)
|
|
|> Goal.finish lthy
|
|
|> Object_Logic.rulify lthy
|
|
val new_thms = map (prove_partial_pred rewrite_thm) final_props
|
|
|
|
(*
|
|
* Make the theorems polymorphic in their exception type.
|
|
*
|
|
* That is, these theories may all be applied regardless of what the type of
|
|
* the exception part of the monad is, but are currently specialised to
|
|
* when the exception part of the monad is unit. We apply a "polymorphism theorem" to change
|
|
* the type of the rule from:
|
|
*
|
|
* ('s, unit + 'a) nondet_monad
|
|
*
|
|
* to
|
|
*
|
|
* ('s, 'e + 'a) nondet_monad
|
|
*)
|
|
val new_thms = map (fn t => #polymorphic_thm rule_set' OF [t]) new_thms
|
|
|> map (fn t => Drule.generalize (Names.empty, Names.make_set ["rec_measure'"]) t)
|
|
|
|
(* Final mono rules for recursive functions. *)
|
|
fun try_mono_thm (fn_name, rewrite_thm) =
|
|
case #mono_thm (the (Symtab.lookup l2_infos fn_name)) of
|
|
NONE => NONE
|
|
| SOME l2_mono_thm =>
|
|
case try (#prove_mono rule_set' rewrite_thm) l2_mono_thm of
|
|
NONE => (Utils.ac_warning ("Failed to prove monad_mono for function: " ^ fn_name);
|
|
NONE)
|
|
| SOME ts_mono_thm => SOME (fn_name, ts_mono_thm);
|
|
val mono_thms = (if is_recursive then List.mapPartial try_mono_thm (fn_names ~~ new_thms) else [])
|
|
|> Symtab.make;
|
|
|
|
val ts_infos =
|
|
map (fn ((f, l2_info), (ts_def, ts_corres)) => let
|
|
val mono_thm = Symtab.lookup mono_thms f;
|
|
val const = Utils.get_term lthy (make_function_name f);
|
|
val ts_info = l2_info
|
|
|> FunctionInfo.function_info_upd_phase FunctionInfo.TS
|
|
|> FunctionInfo.function_info_upd_definition ts_def
|
|
|> FunctionInfo.function_info_upd_corres_thm ts_corres
|
|
|> FunctionInfo.function_info_upd_const const
|
|
|> FunctionInfo.function_info_upd_mono_thm mono_thm;
|
|
in (f, ts_info) end)
|
|
((fn_names ~~ these_l2_infos) ~~ (ts_defs ~~ new_thms))
|
|
in
|
|
(lthy, Symtab.make ts_infos, #name rule_set')
|
|
end
|
|
|
|
|
|
(* Return the lifting rule(s) to try for a function set.
|
|
This is moved out of lift_function so that it can be used to
|
|
provide argument checking in the AutoCorres.abstract wrapper. *)
|
|
fun compute_lift_rules rules force_lift fn_names =
|
|
let
|
|
fun all_list f xs = fold (fn x => (fn b => b andalso f x)) xs true
|
|
|
|
val forced = fn_names
|
|
|> map (fn func => case Symtab.lookup force_lift func of
|
|
SOME rule => [(func, rule)]
|
|
| NONE => [])
|
|
|> List.concat
|
|
in
|
|
case forced of
|
|
[] => rules (* No restrictions *)
|
|
| ((func, rule) :: rest) =>
|
|
(* Functions in the same set must all use the same lifting rule. *)
|
|
if map snd rest |> all_list (fn rule' => #name rule = #name rule')
|
|
then [rule] (* Try the specified rule *)
|
|
else error ("autocorres: this set of mutually recursive functions " ^
|
|
"cannot be lifted to different monads: " ^
|
|
commas_quote (map fst forced))
|
|
end
|
|
|
|
|
|
(* Lift the given function set, trying each rule until one succeeds. *)
|
|
fun lift_function rules force_lift filename prog_info l2_infos ts_infos
|
|
fn_names make_function_name keep_going do_opt lthy =
|
|
let
|
|
val rules' = compute_lift_rules rules force_lift fn_names
|
|
|
|
(* Find the first lift that works. *)
|
|
fun first (rule::xs) =
|
|
(lift_function_rewrite rule filename prog_info l2_infos ts_infos
|
|
fn_names make_function_name keep_going do_opt lthy
|
|
handle LiftingFailed _ => first xs)
|
|
| first [] = raise AllLiftingFailed (map (fn f =>
|
|
(f, #definition (the (Symtab.lookup l2_infos f)))) fn_names)
|
|
in
|
|
first rules'
|
|
end
|
|
|
|
(* Show how many functions were lifted to each monad. *)
|
|
fun print_statistics results =
|
|
let
|
|
fun count_dups x [] = [x]
|
|
| count_dups (head, count) (next::rest) =
|
|
if head = next then
|
|
count_dups (head, count + 1) rest
|
|
else
|
|
(head, count) :: (count_dups (next, 1) rest)
|
|
val tabulated = count_dups ("__fake__", 0) (sort_strings results) |> tl
|
|
val data = map (fn (a,b) =>
|
|
(" " ^ a ^ ": " ^ (@{make_string} b) ^ "\n")
|
|
) tabulated
|
|
|> String.concat
|
|
in
|
|
writeln ("Type Strengthening Statistics: \n" ^ data)
|
|
end
|
|
|
|
(* Run through every function, attempting to strengthen its type.
|
|
* FIXME: this stage is currently completely sequential. Conversions
|
|
* that do not depend on each other should be in parallel;
|
|
* this requires splitting the convert and define stages as usual. *)
|
|
fun translate
|
|
(rules : Monad_Types.monad_type list)
|
|
(force_lift : Monad_Types.monad_type Symtab.table)
|
|
(filename : string)
|
|
(prog_info : ProgramInfo.prog_info)
|
|
(l2_results : FunctionInfo.phase_results)
|
|
(existing_l2_infos : FunctionInfo.function_info Symtab.table)
|
|
(existing_ts_infos : FunctionInfo.function_info Symtab.table)
|
|
(make_function_name : string -> string)
|
|
(keep_going : bool)
|
|
(do_opt : bool)
|
|
(add_trace: string -> string -> AutoCorresData.Trace -> unit)
|
|
: FunctionInfo.phase_results =
|
|
if FSeq.null l2_results then FSeq.empty () else
|
|
let
|
|
(* Wait for previous stage to finish first. *)
|
|
val l2_results = FSeq.list_of l2_results;
|
|
val lthy = List.last l2_results |> fst;
|
|
val l2_infos = Utils.symtab_merge false (map snd l2_results);
|
|
|
|
(* Prettify bound variable names in definitions. *)
|
|
val l2_infos = Symtab.map (fn f_name => fn info => let
|
|
val def = #definition (the (Symtab.lookup l2_infos f_name));
|
|
val pretty_def = PrettyBoundVarNames.pretty_bound_vars_thm
|
|
lthy (Utils.crhs_of (Thm.cprop_of def)) keep_going
|
|
|> Thm.transitive def;
|
|
in FunctionInfo.function_info_upd_definition pretty_def info end)
|
|
l2_infos;
|
|
|
|
(* Add prior L2 translations to round out L2 callees. *)
|
|
val l2_infos = AutoCorresUtil.add_background_callees existing_l2_infos l2_infos;
|
|
val l2_infos = Symtab.merge (K false) (l2_infos, existing_l2_infos);
|
|
|
|
(* For now, just works sequentially like the old TypeStrengthen. *)
|
|
fun translate_group fn_names (lthy, _, ts_infos) =
|
|
let
|
|
val _ = writeln ("Translating (type strengthen) " ^ Utils.commas fn_names);
|
|
val start_time = Timer.startRealTimer ();
|
|
|
|
val (lthy, new_ts_infos, monad_name) =
|
|
lift_function rules force_lift filename prog_info l2_infos ts_infos
|
|
fn_names make_function_name keep_going do_opt lthy;
|
|
|
|
val _ = writeln (" --> " ^ monad_name);
|
|
val _ = tracing ("Converted (TS) " ^ Utils.commas fn_names ^ " in " ^
|
|
Time.toString (Timer.checkRealTimer start_time) ^ " s");
|
|
in (lthy, new_ts_infos, Symtab.merge (K false) (ts_infos, new_ts_infos)) end;
|
|
|
|
val ts_results =
|
|
Utils.accumulate translate_group (lthy, Symtab.empty, existing_ts_infos)
|
|
(map (map fst o Symtab.dest o snd) l2_results)
|
|
|> fst
|
|
|> map (fn (lthy, ts_infos, _) => (lthy, ts_infos));
|
|
in
|
|
FSeq.of_list ts_results
|
|
end
|
|
|
|
end
|