src/Tools/Code/code_simp.ML
author haftmann
Wed, 15 Dec 2010 09:47:12 +0100
changeset 41184 5c6f44d22f51
parent 39606 7af0441a3a47
child 41188 7cded8957e72
permissions -rw-r--r--
simplified evaluation function names
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
37744
3daaf23b9ab4 tuned titles
haftmann
parents: 37463
diff changeset
     1
(*  Title:      Tools/Code/code_simp.ML
37442
037ee7b712b2 added code_simp infrastructure
haftmann
parents:
diff changeset
     2
    Author:     Florian Haftmann, TU Muenchen
037ee7b712b2 added code_simp infrastructure
haftmann
parents:
diff changeset
     3
037ee7b712b2 added code_simp infrastructure
haftmann
parents:
diff changeset
     4
Connecting the simplifier and the code generator.
037ee7b712b2 added code_simp infrastructure
haftmann
parents:
diff changeset
     5
*)
037ee7b712b2 added code_simp infrastructure
haftmann
parents:
diff changeset
     6
037ee7b712b2 added code_simp infrastructure
haftmann
parents:
diff changeset
     7
signature CODE_SIMP =
037ee7b712b2 added code_simp infrastructure
haftmann
parents:
diff changeset
     8
sig
037ee7b712b2 added code_simp infrastructure
haftmann
parents:
diff changeset
     9
  val map_ss: (simpset -> simpset) -> theory -> theory
41184
5c6f44d22f51 simplified evaluation function names
haftmann
parents: 39606
diff changeset
    10
  val dynamic_conv: conv
38669
9ff76d0f0610 refined and unified naming convention for dynamic code evaluation techniques
haftmann
parents: 37839
diff changeset
    11
  val dynamic_eval_tac: theory -> int -> tactic
41184
5c6f44d22f51 simplified evaluation function names
haftmann
parents: 39606
diff changeset
    12
  val dynamic_value: theory -> term -> term
5c6f44d22f51 simplified evaluation function names
haftmann
parents: 39606
diff changeset
    13
  val static_conv: theory -> simpset option -> string list -> conv
38669
9ff76d0f0610 refined and unified naming convention for dynamic code evaluation techniques
haftmann
parents: 37839
diff changeset
    14
  val static_eval_tac: theory -> simpset option -> string list -> int -> tactic
37442
037ee7b712b2 added code_simp infrastructure
haftmann
parents:
diff changeset
    15
  val setup: theory -> theory
037ee7b712b2 added code_simp infrastructure
haftmann
parents:
diff changeset
    16
end;
037ee7b712b2 added code_simp infrastructure
haftmann
parents:
diff changeset
    17
037ee7b712b2 added code_simp infrastructure
haftmann
parents:
diff changeset
    18
structure Code_Simp : CODE_SIMP =
037ee7b712b2 added code_simp infrastructure
haftmann
parents:
diff changeset
    19
struct
037ee7b712b2 added code_simp infrastructure
haftmann
parents:
diff changeset
    20
037ee7b712b2 added code_simp infrastructure
haftmann
parents:
diff changeset
    21
(* dedicated simpset *)
037ee7b712b2 added code_simp infrastructure
haftmann
parents:
diff changeset
    22
38759
37a9092de102 simplification/standardization of some theory data;
wenzelm
parents: 38671
diff changeset
    23
structure Simpset = Theory_Data
37a9092de102 simplification/standardization of some theory data;
wenzelm
parents: 38671
diff changeset
    24
(
37442
037ee7b712b2 added code_simp infrastructure
haftmann
parents:
diff changeset
    25
  type T = simpset;
037ee7b712b2 added code_simp infrastructure
haftmann
parents:
diff changeset
    26
  val empty = empty_ss;
037ee7b712b2 added code_simp infrastructure
haftmann
parents:
diff changeset
    27
  fun extend ss = MetaSimplifier.inherit_context empty_ss ss;
037ee7b712b2 added code_simp infrastructure
haftmann
parents:
diff changeset
    28
  val merge = merge_ss;
037ee7b712b2 added code_simp infrastructure
haftmann
parents:
diff changeset
    29
);
037ee7b712b2 added code_simp infrastructure
haftmann
parents:
diff changeset
    30
037ee7b712b2 added code_simp infrastructure
haftmann
parents:
diff changeset
    31
val map_ss = Simpset.map;
037ee7b712b2 added code_simp infrastructure
haftmann
parents:
diff changeset
    32
37461
3489cea0e0e9 conclude simplification with default simpset
haftmann
parents: 37449
diff changeset
    33
fun simpset_default thy = Simplifier.global_context thy o the_default (Simpset.get thy);
3489cea0e0e9 conclude simplification with default simpset
haftmann
parents: 37449
diff changeset
    34
37442
037ee7b712b2 added code_simp infrastructure
haftmann
parents:
diff changeset
    35
037ee7b712b2 added code_simp infrastructure
haftmann
parents:
diff changeset
    36
(* build simpset and conversion from program *)
037ee7b712b2 added code_simp infrastructure
haftmann
parents:
diff changeset
    37
037ee7b712b2 added code_simp infrastructure
haftmann
parents:
diff changeset
    38
fun add_stmt (Code_Thingol.Fun (_, ((_, eqs), some_cong))) ss =
037ee7b712b2 added code_simp infrastructure
haftmann
parents:
diff changeset
    39
      ss addsimps (map_filter (fst o snd)) eqs addcongs (the_list some_cong)
37449
034ebe92f090 more precise code
haftmann
parents: 37444
diff changeset
    40
  | add_stmt (Code_Thingol.Classinst (_, (_, (classparam_instances, _)))) ss =
034ebe92f090 more precise code
haftmann
parents: 37444
diff changeset
    41
      ss addsimps (map (fst o snd) classparam_instances)
37442
037ee7b712b2 added code_simp infrastructure
haftmann
parents:
diff changeset
    42
  | add_stmt _ ss = ss;
037ee7b712b2 added code_simp infrastructure
haftmann
parents:
diff changeset
    43
37839
b77e521e9f50 tuned interpunctation
haftmann
parents: 37744
diff changeset
    44
val add_program = Graph.fold (add_stmt o fst o snd);
37442
037ee7b712b2 added code_simp infrastructure
haftmann
parents:
diff changeset
    45
037ee7b712b2 added code_simp infrastructure
haftmann
parents:
diff changeset
    46
fun rewrite_modulo thy some_ss program = Simplifier.full_rewrite
37461
3489cea0e0e9 conclude simplification with default simpset
haftmann
parents: 37449
diff changeset
    47
  (add_program program (simpset_default thy some_ss));
3489cea0e0e9 conclude simplification with default simpset
haftmann
parents: 37449
diff changeset
    48
3489cea0e0e9 conclude simplification with default simpset
haftmann
parents: 37449
diff changeset
    49
fun conclude_tac thy some_ss = Simplifier.full_simp_tac (simpset_default thy some_ss);
37442
037ee7b712b2 added code_simp infrastructure
haftmann
parents:
diff changeset
    50
037ee7b712b2 added code_simp infrastructure
haftmann
parents:
diff changeset
    51
39486
e992bcc4440e refined static_eval_conv_simple; tuned comments
haftmann
parents: 39475
diff changeset
    52
(* evaluation with dynamic code context *)
37442
037ee7b712b2 added code_simp infrastructure
haftmann
parents:
diff changeset
    53
41184
5c6f44d22f51 simplified evaluation function names
haftmann
parents: 39606
diff changeset
    54
val dynamic_conv = Conv.tap_thy (fn thy => Code_Thingol.dynamic_conv thy
39606
7af0441a3a47 no_frees_* is subsumed by new framework mechanisms in Code_Preproc
haftmann
parents: 39601
diff changeset
    55
  (fn naming => fn program => fn t => fn deps => rewrite_modulo thy NONE program));
37442
037ee7b712b2 added code_simp infrastructure
haftmann
parents:
diff changeset
    56
41184
5c6f44d22f51 simplified evaluation function names
haftmann
parents: 39606
diff changeset
    57
fun dynamic_eval_tac thy = CONVERSION dynamic_conv THEN' conclude_tac thy NONE;
37442
037ee7b712b2 added code_simp infrastructure
haftmann
parents:
diff changeset
    58
41184
5c6f44d22f51 simplified evaluation function names
haftmann
parents: 39606
diff changeset
    59
fun dynamic_value thy = snd o Logic.dest_equals o Thm.prop_of o dynamic_conv o Thm.cterm_of thy;
37444
2e7e7ff21e25 added simp evaluator
haftmann
parents: 37442
diff changeset
    60
37442
037ee7b712b2 added code_simp infrastructure
haftmann
parents:
diff changeset
    61
val setup = Method.setup (Binding.name "code_simp")
38669
9ff76d0f0610 refined and unified naming convention for dynamic code evaluation techniques
haftmann
parents: 37839
diff changeset
    62
  (Scan.succeed (SIMPLE_METHOD' o (CHANGED_PROP oo dynamic_eval_tac o ProofContext.theory_of)))
37442
037ee7b712b2 added code_simp infrastructure
haftmann
parents:
diff changeset
    63
  "simplification with code equations"
41184
5c6f44d22f51 simplified evaluation function names
haftmann
parents: 39606
diff changeset
    64
  #> Value.add_evaluator ("simp", dynamic_value o ProofContext.theory_of);
37442
037ee7b712b2 added code_simp infrastructure
haftmann
parents:
diff changeset
    65
037ee7b712b2 added code_simp infrastructure
haftmann
parents:
diff changeset
    66
39486
e992bcc4440e refined static_eval_conv_simple; tuned comments
haftmann
parents: 39475
diff changeset
    67
(* evaluation with static code context *)
37442
037ee7b712b2 added code_simp infrastructure
haftmann
parents:
diff changeset
    68
41184
5c6f44d22f51 simplified evaluation function names
haftmann
parents: 39606
diff changeset
    69
fun static_conv thy some_ss consts =
5c6f44d22f51 simplified evaluation function names
haftmann
parents: 39606
diff changeset
    70
  Code_Thingol.static_conv_simple thy consts
39606
7af0441a3a47 no_frees_* is subsumed by new framework mechanisms in Code_Preproc
haftmann
parents: 39601
diff changeset
    71
    (fn program => fn thy => fn _ => fn _ => rewrite_modulo thy some_ss program);
37442
037ee7b712b2 added code_simp infrastructure
haftmann
parents:
diff changeset
    72
41184
5c6f44d22f51 simplified evaluation function names
haftmann
parents: 39606
diff changeset
    73
fun static_eval_tac thy some_ss consts = CONVERSION (static_conv thy some_ss consts)
37461
3489cea0e0e9 conclude simplification with default simpset
haftmann
parents: 37449
diff changeset
    74
  THEN' conclude_tac thy some_ss;
37442
037ee7b712b2 added code_simp infrastructure
haftmann
parents:
diff changeset
    75
037ee7b712b2 added code_simp infrastructure
haftmann
parents:
diff changeset
    76
end;