src/Tools/Code/code_runtime.ML
changeset 55147 bce3dbc11f95
parent 53171 a5e54d4d9081
child 55150 0940309ed8f1
equal deleted inserted replaced
55146:525309c2e4ee 55147:bce3dbc11f95
    50 val structure_generated = "Generated_Code";
    50 val structure_generated = "Generated_Code";
    51 
    51 
    52 datatype truth = Holds;
    52 datatype truth = Holds;
    53 
    53 
    54 val _ = Theory.setup
    54 val _ = Theory.setup
    55   (Code_Target.extend_target (target, (Code_ML.target_SML, K I))
    55   (Code_Target.extend_target (target, (Code_ML.target_SML, I))
    56   #> Code_Target.set_printings (Code_Symbol.Type_Constructor (@{type_name prop},
    56   #> Code_Target.set_printings (Code_Symbol.Type_Constructor (@{type_name prop},
    57     [(target, SOME (0, (K o K o K) (Code_Printer.str s_truth)))]))
    57     [(target, SOME (0, (K o K o K) (Code_Printer.str s_truth)))]))
    58   #> Code_Target.set_printings (Code_Symbol.Constant (@{const_name Code_Generator.holds},
    58   #> Code_Target.set_printings (Code_Symbol.Constant (@{const_name Code_Generator.holds},
    59     [(target, SOME (Code_Printer.plain_const_syntax s_Holds))]))
    59     [(target, SOME (Code_Printer.plain_const_syntax s_Holds))]))
    60   #> Code_Target.add_reserved target this
    60   #> Code_Target.add_reserved target this
    85 fun reject_vars thy t =
    85 fun reject_vars thy t =
    86   let
    86   let
    87     val ctxt = Proof_Context.init_global thy;
    87     val ctxt = Proof_Context.init_global thy;
    88   in ((Sign.no_frees ctxt o Sign.no_vars ctxt o map_types (K dummyT)) t; t) end;
    88   in ((Sign.no_frees ctxt o Sign.no_vars ctxt o map_types (K dummyT)) t; t) end;
    89 
    89 
    90 fun obtain_evaluator thy some_target naming program consts expr =
    90 fun obtain_evaluator thy some_target program consts expr =
    91   Code_Target.evaluator thy (the_default target some_target) naming program consts expr
    91   Code_Target.evaluator thy (the_default target some_target) program consts expr
    92   |> apfst (fn ml_modules => space_implode "\n\n" (map snd ml_modules));
    92   |> apfst (fn ml_modules => space_implode "\n\n" (map snd ml_modules));
       
    93 
       
    94 fun obtain_evaluator' thy some_target program =
       
    95   obtain_evaluator thy some_target program o map Code_Symbol.Constant;
    93 
    96 
    94 fun evaluation cookie thy evaluator vs_t args =
    97 fun evaluation cookie thy evaluator vs_t args =
    95   let
    98   let
    96     val ctxt = Proof_Context.init_global thy;
    99     val ctxt = Proof_Context.init_global thy;
    97     val (program_code, value_name) = evaluator vs_t;
   100     val (program_code, value_name) = evaluator vs_t;
   108   let
   111   let
   109     val _ = reject_vars thy t;
   112     val _ = reject_vars thy t;
   110     val _ = if ! trace
   113     val _ = if ! trace
   111       then tracing ("Evaluation of term " ^ quote (Syntax.string_of_term_global thy t))
   114       then tracing ("Evaluation of term " ^ quote (Syntax.string_of_term_global thy t))
   112       else ()
   115       else ()
   113     fun evaluator naming program ((_, vs_ty), t) deps =
   116     fun evaluator program ((_, vs_ty), t) deps =
   114       evaluation cookie thy (obtain_evaluator thy some_target naming program deps) (vs_ty, t) args;
   117       evaluation cookie thy (obtain_evaluator thy some_target program deps) (vs_ty, t) args;
   115   in Code_Thingol.dynamic_value thy (Exn.map_result o postproc) evaluator t end;
   118   in Code_Thingol.dynamic_value thy (Exn.map_result o postproc) evaluator t end;
   116 
   119 
   117 fun dynamic_value_strict cookie thy some_target postproc t args =
   120 fun dynamic_value_strict cookie thy some_target postproc t args =
   118   Exn.release (dynamic_value_exn cookie thy some_target postproc t args);
   121   Exn.release (dynamic_value_exn cookie thy some_target postproc t args);
   119 
   122 
   120 fun dynamic_value cookie thy some_target postproc t args =
   123 fun dynamic_value cookie thy some_target postproc t args =
   121   partiality_as_none (dynamic_value_exn cookie thy some_target postproc t args);
   124   partiality_as_none (dynamic_value_exn cookie thy some_target postproc t args);
   122 
   125 
   123 fun static_evaluator cookie thy some_target naming program consts' =
   126 fun static_evaluator cookie thy some_target program consts' =
   124   let
   127   let
   125     val evaluator = obtain_evaluator thy some_target naming program consts'
   128     val evaluator = obtain_evaluator' thy some_target program consts'
   126   in fn ((_, vs_ty), t) => fn _ => evaluation cookie thy evaluator (vs_ty, t) [] end;
   129   in fn ((_, vs_ty), t) => fn _ => evaluation cookie thy evaluator (vs_ty, t) [] end;
   127 
   130 
   128 fun static_value_exn cookie thy some_target postproc consts =
   131 fun static_value_exn cookie thy some_target postproc consts =
   129   Code_Thingol.static_value thy (Exn.map_result o postproc) consts
   132   Code_Thingol.static_value thy (Exn.map_result o postproc) consts
   130     (static_evaluator cookie thy some_target) o reject_vars thy;
   133     (static_evaluator cookie thy some_target) o reject_vars thy;
   173   raw_check_holds_oracle (thy, evaluator, (vs_ty, t), ct);
   176   raw_check_holds_oracle (thy, evaluator, (vs_ty, t), ct);
   174 
   177 
   175 in
   178 in
   176 
   179 
   177 fun dynamic_holds_conv thy = Code_Thingol.dynamic_conv thy
   180 fun dynamic_holds_conv thy = Code_Thingol.dynamic_conv thy
   178   (fn naming => fn program => fn vs_t => fn deps =>
   181   (fn program => fn vs_t => fn deps =>
   179     check_holds_oracle thy (obtain_evaluator thy NONE naming program deps) vs_t deps)
   182     check_holds_oracle thy (obtain_evaluator thy NONE program deps) vs_t deps)
   180       o reject_vars thy;
   183       o reject_vars thy;
   181 
   184 
   182 fun static_holds_conv thy consts = Code_Thingol.static_conv thy consts
   185 fun static_holds_conv thy consts = Code_Thingol.static_conv thy consts
   183   (fn naming => fn program => fn consts' =>
   186   (fn program => fn consts' =>
   184     check_holds_oracle thy (obtain_evaluator thy NONE naming program consts'))
   187     check_holds_oracle thy (obtain_evaluator' thy NONE program consts'))
   185       o reject_vars thy;
   188       o reject_vars thy;
   186 
   189 
   187 end; (*local*)
   190 end; (*local*)
   188 
   191 
   189 
   192 
   190 (** instrumentalization **)
   193 (** instrumentalization **)
   191 
   194 
   192 fun evaluation_code thy module_name tycos consts =
   195 fun evaluation_code thy module_name tycos consts =
   193   let
   196   let
   194     val ctxt = Proof_Context.init_global thy;
   197     val ctxt = Proof_Context.init_global thy;
   195     val (consts', (naming, program)) = Code_Thingol.consts_program thy false consts;
   198     val program = Code_Thingol.consts_program thy false consts;
   196     val tycos' = map (the o Code_Thingol.lookup_tyco naming) tycos;
       
   197     val (ml_modules, target_names) =
   199     val (ml_modules, target_names) =
   198       Code_Target.produce_code_for thy
   200       Code_Target.produce_code_for thy
   199         target NONE module_name [] naming program (consts' @ tycos');
   201         target NONE module_name [] program (map Code_Symbol.Constant consts @ map Code_Symbol.Type_Constructor tycos);
   200     val ml_code = space_implode "\n\n" (map snd ml_modules);
   202     val ml_code = space_implode "\n\n" (map snd ml_modules);
   201     val (consts'', tycos'') = chop (length consts') target_names;
   203     val (consts', tycos') = chop (length consts) target_names;
   202     val consts_map = map2 (fn const =>
   204     val consts_map = map2 (fn const =>
   203       fn NONE =>
   205       fn NONE =>
   204           error ("Constant " ^ (quote o Code.string_of_const thy) const ^
   206           error ("Constant " ^ (quote o Code.string_of_const thy) const ^
   205             "\nhas a user-defined serialization")
   207             "\nhas a user-defined serialization")
   206        | SOME const'' => (const, const'')) consts consts''
   208        | SOME const' => (const, const')) consts consts'
   207     val tycos_map = map2 (fn tyco =>
   209     val tycos_map = map2 (fn tyco =>
   208       fn NONE =>
   210       fn NONE =>
   209           error ("Type " ^ quote (Proof_Context.extern_type ctxt tyco) ^
   211           error ("Type " ^ quote (Proof_Context.extern_type ctxt tyco) ^
   210             "\nhas a user-defined serialization")
   212             "\nhas a user-defined serialization")
   211         | SOME tyco'' => (tyco, tyco'')) tycos tycos'';
   213         | SOME tyco' => (tyco, tyco')) tycos tycos';
   212   in (ml_code, (tycos_map, consts_map)) end;
   214   in (ml_code, (tycos_map, consts_map)) end;
   213 
   215 
   214 
   216 
   215 (* by antiquotation *)
   217 (* by antiquotation *)
   216 
   218