src/Tools/Code/code_simp.ML
changeset 55757 9fc71814b8c1
parent 55147 bce3dbc11f95
child 56808 d4a790cb47e8
equal deleted inserted replaced
55756:565a20b22f09 55757:9fc71814b8c1
     5 *)
     5 *)
     6 
     6 
     7 signature CODE_SIMP =
     7 signature CODE_SIMP =
     8 sig
     8 sig
     9   val map_ss: (Proof.context -> Proof.context) -> theory -> theory
     9   val map_ss: (Proof.context -> Proof.context) -> theory -> theory
    10   val dynamic_conv: theory -> conv
    10   val dynamic_conv: Proof.context -> conv
    11   val dynamic_tac: theory -> int -> tactic
    11   val dynamic_tac: Proof.context -> int -> tactic
    12   val dynamic_value: theory -> term -> term
    12   val dynamic_value: Proof.context -> term -> term
    13   val static_conv: theory -> simpset option -> string list -> conv
    13   val static_conv: Proof.context -> simpset option -> string list -> Proof.context -> conv
    14   val static_tac: theory -> simpset option -> string list -> Proof.context -> int -> tactic
    14   val static_tac: Proof.context -> simpset option -> string list -> Proof.context -> int -> tactic
    15   val setup: theory -> theory
    15   val setup: theory -> theory
    16   val trace: bool Config.T
    16   val trace: bool Config.T
    17 end;
    17 end;
    18 
    18 
    19 structure Code_Simp : CODE_SIMP =
    19 structure Code_Simp : CODE_SIMP =
    29   val merge = merge_ss;
    29   val merge = merge_ss;
    30 );
    30 );
    31 
    31 
    32 fun map_ss f thy = Simpset.map (simpset_map (Proof_Context.init_global thy) f) thy;
    32 fun map_ss f thy = Simpset.map (simpset_map (Proof_Context.init_global thy) f) thy;
    33 
    33 
    34 fun simpset_default thy some_ss = the_default (Simpset.get thy) some_ss;
    34 fun simpset_default ctxt some_ss = the_default (Simpset.get (Proof_Context.theory_of ctxt)) some_ss;
    35 
    35 
    36 fun simp_ctxt_default thy some_ss =
    36 (*fun simp_ctxt_default ctxt some_ss =
    37   Proof_Context.init_global thy
    37   Proof_Context.init_global ctxt
    38   |> put_simpset (simpset_default thy some_ss);
    38   |> put_simpset (simpset_default ctxt some_ss);*)
    39 
    39 
    40 
    40 
    41 (* diagnostic *)
    41 (* diagnostic *)
    42 
    42 
    43 val trace = Attrib.setup_config_bool @{binding "code_simp_trace"} (K false);
    43 val trace = Attrib.setup_config_bool @{binding "code_simp_trace"} (K false);
    48   in
    48   in
    49     ctxt |> Config.map Simplifier.simp_trace (fn b => b orelse global)
    49     ctxt |> Config.map Simplifier.simp_trace (fn b => b orelse global)
    50   end;
    50   end;
    51 
    51 
    52 
    52 
    53 (* build simpset and conversion from program *)
    53 (* build simpset context and conversion from program *)
    54 
    54 
    55 fun add_stmt (Code_Thingol.Fun ((_, eqs), some_cong)) ss =
    55 fun add_stmt (Code_Thingol.Fun ((_, eqs), some_cong)) ss =
    56       ss
    56       ss
    57       |> fold Simplifier.add_simp ((map_filter (fst o snd)) eqs)
    57       |> fold Simplifier.add_simp ((map_filter (fst o snd)) eqs)
    58       |> fold Simplifier.add_cong (the_list some_cong)
    58       |> fold Simplifier.add_cong (the_list some_cong)
    61       |> fold Simplifier.add_simp (map (fst o snd) inst_params)
    61       |> fold Simplifier.add_simp (map (fst o snd) inst_params)
    62   | add_stmt _ ss = ss;
    62   | add_stmt _ ss = ss;
    63 
    63 
    64 val add_program = Code_Symbol.Graph.fold (add_stmt o fst o snd);
    64 val add_program = Code_Symbol.Graph.fold (add_stmt o fst o snd);
    65 
    65 
    66 fun simp_ctxt_program thy some_ss program =
    66 fun simpset_program ctxt some_ss program =
    67   simp_ctxt_default thy some_ss
    67   simpset_map ctxt (add_program program) (simpset_default ctxt some_ss);
    68   |> add_program program;
       
    69 
    68 
    70 fun rewrite_modulo thy some_ss program =
    69 fun rewrite_modulo ctxt some_ss program =
    71   Simplifier.full_rewrite (simp_ctxt_program thy some_ss program |> set_trace);
    70   let
       
    71     val ss = simpset_program ctxt some_ss program;
       
    72   in fn ctxt => Simplifier.full_rewrite (ctxt |> put_simpset ss |> set_trace) end;
    72 
    73 
    73 fun conclude_tac thy some_ss =
    74 fun conclude_tac ctxt some_ss =
    74   Simplifier.full_simp_tac o Simplifier.put_simpset (simpset_default thy some_ss);
    75   let
       
    76     val ss = simpset_default ctxt some_ss
       
    77   in fn ctxt => Simplifier.full_simp_tac (ctxt |> put_simpset ss) end;
    75 
    78 
    76 
    79 
    77 (* evaluation with dynamic code context *)
    80 (* evaluation with dynamic code context *)
    78 
    81 
    79 fun dynamic_conv thy = Code_Thingol.dynamic_conv thy
    82 fun dynamic_conv ctxt = Code_Thingol.dynamic_conv ctxt
    80   (fn program => fn _ => fn _ => rewrite_modulo thy NONE program);
    83   (fn program => fn _ => fn _ => rewrite_modulo ctxt NONE program ctxt);
    81 
    84 
    82 fun dynamic_tac thy = CONVERSION (dynamic_conv thy) THEN' conclude_tac thy NONE (Proof_Context.init_global thy);
    85 fun dynamic_tac ctxt = CONVERSION (dynamic_conv ctxt)
       
    86   THEN' conclude_tac ctxt NONE ctxt;
    83 
    87 
    84 fun dynamic_value thy = snd o Logic.dest_equals o Thm.prop_of o dynamic_conv thy o Thm.cterm_of thy;
    88 fun dynamic_value ctxt =
       
    89   snd o Logic.dest_equals o Thm.prop_of o dynamic_conv ctxt o Thm.cterm_of (Proof_Context.theory_of ctxt);
    85 
    90 
    86 val setup =
    91 val setup =
    87   Method.setup @{binding code_simp}
    92   Method.setup @{binding code_simp}
    88     (Scan.succeed (SIMPLE_METHOD' o (CHANGED_PROP oo dynamic_tac o Proof_Context.theory_of)))
    93     (Scan.succeed (SIMPLE_METHOD' o (CHANGED_PROP oo dynamic_tac)))
    89     "simplification with code equations"
    94     "simplification with code equations"
    90   #> Value.add_evaluator ("simp", dynamic_value o Proof_Context.theory_of);
    95   #> Value.add_evaluator ("simp", dynamic_value);
    91 
    96 
    92 
    97 
    93 (* evaluation with static code context *)
    98 (* evaluation with static code context *)
    94 
    99 
    95 fun static_conv thy some_ss consts =
   100 fun static_conv ctxt some_ss consts =
    96   Code_Thingol.static_conv_simple thy consts
   101   Code_Thingol.static_conv_simple ctxt consts
    97     (fn program => fn _ => fn _ => rewrite_modulo thy some_ss program);
   102     (fn program => let val conv' = rewrite_modulo ctxt some_ss program
       
   103      in fn ctxt' => fn _ => fn _ => conv' ctxt' end);
    98 
   104 
    99 fun static_tac thy some_ss consts =
   105 fun static_tac ctxt some_ss consts =
   100   let
   106   let
   101     val conv = static_conv thy some_ss consts;
   107     val conv = static_conv ctxt some_ss consts;
   102     val tac = conclude_tac thy some_ss;
   108     val tac = conclude_tac ctxt some_ss;
   103   in fn ctxt => CONVERSION conv THEN' tac ctxt end;
   109   in fn ctxt' => CONVERSION (conv ctxt') THEN' (tac ctxt') end;
   104 
   110 
   105 end;
   111 end;