src/Tools/Code/code_simp.ML
author wenzelm
Sun, 13 Mar 2011 14:51:38 +0100
changeset 41940 a3b68a7a0e15
parent 41346 6673f6fa94ca
child 42361 23f352990944
permissions -rw-r--r--
allow spaces in executable names; simplified generated bash scripts;
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
41247
c5cb19ecbd41 avoid slightly odd Conv.tap_thy
haftmann
parents: 41188
diff changeset
    10
  val dynamic_conv: theory -> conv
41188
7cded8957e72 more uniform naming
haftmann
parents: 41184
diff changeset
    11
  val dynamic_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
41188
7cded8957e72 more uniform naming
haftmann
parents: 41184
diff changeset
    14
  val static_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;
41225
bd4ecd48c21f refer to regular structure Simplifier;
wenzelm
parents: 41188
diff changeset
    27
  fun extend ss = Simplifier.inherit_context empty_ss ss;
37442
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
41247
c5cb19ecbd41 avoid slightly odd Conv.tap_thy
haftmann
parents: 41188
diff changeset
    54
fun dynamic_conv thy = Code_Thingol.dynamic_conv thy
c5cb19ecbd41 avoid slightly odd Conv.tap_thy
haftmann
parents: 41188
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
41247
c5cb19ecbd41 avoid slightly odd Conv.tap_thy
haftmann
parents: 41188
diff changeset
    57
fun dynamic_tac thy = CONVERSION (dynamic_conv thy) THEN' conclude_tac thy NONE;
37442
037ee7b712b2 added code_simp infrastructure
haftmann
parents:
diff changeset
    58
41247
c5cb19ecbd41 avoid slightly odd Conv.tap_thy
haftmann
parents: 41188
diff changeset
    59
fun dynamic_value thy = snd o Logic.dest_equals o Thm.prop_of o dynamic_conv thy 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")
41188
7cded8957e72 more uniform naming
haftmann
parents: 41184
diff changeset
    62
  (Scan.succeed (SIMPLE_METHOD' o (CHANGED_PROP oo dynamic_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
41346
6673f6fa94ca canonical handling of theory context argument
haftmann
parents: 41251
diff changeset
    71
    (fn program => fn _ => fn _ => rewrite_modulo thy some_ss program);
37442
037ee7b712b2 added code_simp infrastructure
haftmann
parents:
diff changeset
    72
41188
7cded8957e72 more uniform naming
haftmann
parents: 41184
diff changeset
    73
fun static_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;