19 type code_graph |
19 type code_graph |
20 val cert: code_graph -> string -> Code.cert |
20 val cert: code_graph -> string -> Code.cert |
21 val sortargs: code_graph -> string -> sort list |
21 val sortargs: code_graph -> string -> sort list |
22 val all: code_graph -> string list |
22 val all: code_graph -> string list |
23 val pretty: Proof.context -> code_graph -> Pretty.T |
23 val pretty: Proof.context -> code_graph -> Pretty.T |
24 val obtain: bool -> Proof.context -> string list -> term list -> |
24 val obtain: bool -> { ctxt: Proof.context, consts: string list, terms: term list } -> |
25 { algebra: code_algebra, eqngr: code_graph } |
25 { algebra: code_algebra, eqngr: code_graph } |
26 val dynamic_conv: Proof.context |
26 val dynamic_conv: Proof.context |
27 -> (code_algebra -> code_graph -> term -> conv) -> conv |
27 -> (code_algebra -> code_graph -> term -> conv) -> conv |
28 val dynamic_value: Proof.context -> ((term -> term) -> 'a -> 'b) |
28 val dynamic_value: Proof.context -> ((term -> term) -> 'a -> 'b) |
29 -> (code_algebra -> code_graph -> term -> 'a) -> term -> 'b |
29 -> (code_algebra -> code_graph -> term -> 'a) -> term -> 'b |
36 |
36 |
37 val trace_none: Context.generic -> Context.generic |
37 val trace_none: Context.generic -> Context.generic |
38 val trace_all: Context.generic -> Context.generic |
38 val trace_all: Context.generic -> Context.generic |
39 val trace_only: string list -> Context.generic -> Context.generic |
39 val trace_only: string list -> Context.generic -> Context.generic |
40 val trace_only_ext: string list -> Context.generic -> Context.generic |
40 val trace_only_ext: string list -> Context.generic -> Context.generic |
|
41 |
|
42 val timing: bool Config.T |
|
43 val timed: string -> ('a -> Proof.context) -> ('a -> 'b) -> 'a -> 'b |
|
44 val timed_exec: string -> (unit -> 'a) -> Proof.context -> 'a |
|
45 val timed_conv: string -> (Proof.context -> conv) -> Proof.context -> conv |
|
46 val timed_value: string -> (Proof.context -> term -> 'a) -> Proof.context -> term -> 'a |
41 end |
47 end |
42 |
48 |
43 structure Code_Preproc : CODE_PREPROC = |
49 structure Code_Preproc : CODE_PREPROC = |
44 struct |
50 struct |
|
51 |
|
52 (** timing **) |
|
53 |
|
54 val timing = Attrib.setup_config_bool @{binding code_timing} (K false); |
|
55 |
|
56 fun timed msg ctxt_of f x = |
|
57 if Config.get (ctxt_of x) timing |
|
58 then timeap_msg msg f x |
|
59 else f x; |
|
60 |
|
61 fun timed_exec msg f ctxt = |
|
62 if Config.get ctxt timing |
|
63 then timeap_msg msg f () |
|
64 else f (); |
|
65 |
|
66 fun timed' msg f ctxt x = |
|
67 if Config.get ctxt timing |
|
68 then timeap_msg msg (f ctxt) x |
|
69 else f ctxt x; |
|
70 |
|
71 val timed_conv = timed'; |
|
72 val timed_value = timed'; |
|
73 |
|
74 |
45 |
75 |
46 (** preprocessor administration **) |
76 (** preprocessor administration **) |
47 |
77 |
48 (* theory data *) |
78 (* theory data *) |
49 |
79 |
210 Simplifier.rewrite (put_simpset pre ctxt') |
240 Simplifier.rewrite (put_simpset pre ctxt') |
211 #> trans_conv_rule (Axclass.unoverload_conv ctxt') |
241 #> trans_conv_rule (Axclass.unoverload_conv ctxt') |
212 fun post_conv ctxt'' = |
242 fun post_conv ctxt'' = |
213 Axclass.overload_conv ctxt'' |
243 Axclass.overload_conv ctxt'' |
214 #> trans_conv_rule (Simplifier.rewrite (put_simpset post ctxt'')) |
244 #> trans_conv_rule (Simplifier.rewrite (put_simpset post ctxt'')) |
215 in fn ctxt' => pre_conv ctxt' #> pair post_conv end; |
245 in |
|
246 fn ctxt' => timed_conv "preprocessing term" pre_conv ctxt' |
|
247 #> pair (timed_conv "postprocessing term" post_conv) |
|
248 end; |
216 |
249 |
217 fun simplifier_sandwich ctxt = |
250 fun simplifier_sandwich ctxt = |
218 Sandwich.lift (simplifier_conv_sandwich ctxt); |
251 Sandwich.lift (simplifier_conv_sandwich ctxt); |
219 |
252 |
220 fun value_sandwich ctxt = |
253 fun value_sandwich ctxt = |
548 * conversion "conv" |
581 * conversion "conv" |
549 * value computation "comp" |
582 * value computation "comp" |
550 * "evaluation" is a lifting of an evaluator |
583 * "evaluation" is a lifting of an evaluator |
551 *) |
584 *) |
552 |
585 |
553 fun obtain ignore_cache ctxt consts ts = apsnd snd |
586 fun obtain ignore_cache = |
554 (Wellsorted.change_yield (if ignore_cache then NONE else SOME (Proof_Context.theory_of ctxt)) |
587 timed "preprocessing equations" #ctxt (fn { ctxt, consts, terms } => |
555 (extend_arities_eqngr ctxt consts ts)) |
588 apsnd snd (Wellsorted.change_yield |
556 |> (fn (algebra, eqngr) => { algebra = algebra, eqngr = eqngr }); |
589 (if ignore_cache then NONE else SOME (Proof_Context.theory_of ctxt)) |
|
590 (extend_arities_eqngr ctxt consts terms))) |
|
591 #> (fn (algebra, eqngr) => { algebra = algebra, eqngr = eqngr }); |
557 |
592 |
558 fun dynamic_evaluation eval ctxt t = |
593 fun dynamic_evaluation eval ctxt t = |
559 let |
594 let |
560 val consts = fold_aterms |
595 val consts = fold_aterms |
561 (fn Const (c, _) => insert (op =) c | _ => I) t []; |
596 (fn Const (c, _) => insert (op =) c | _ => I) t []; |
562 val { algebra, eqngr } = obtain false ctxt consts [t]; |
597 val { algebra, eqngr } = obtain false { ctxt = ctxt, consts = consts, terms = [t] }; |
563 in eval algebra eqngr t end; |
598 in eval algebra eqngr t end; |
564 |
599 |
565 fun static_evaluation ctxt consts eval = |
600 fun static_evaluation ctxt consts eval = |
566 eval (obtain true ctxt consts []); |
601 eval (obtain true { ctxt = ctxt, consts = consts, terms = [] }); |
567 |
602 |
568 fun dynamic_conv ctxt conv = |
603 fun dynamic_conv ctxt conv = |
569 Sandwich.conversion (value_sandwich ctxt) |
604 Sandwich.conversion (value_sandwich ctxt) |
570 (dynamic_evaluation conv) ctxt; |
605 (dynamic_evaluation conv) ctxt; |
571 |
606 |