src/Tools/Code/code_runtime.ML
changeset 41347 064133cb4ef6
parent 41343 71f4f15258a5
child 41348 692c3fbde3c9
equal deleted inserted replaced
41346:6673f6fa94ca 41347:064133cb4ef6
    84 fun reject_vars thy t =
    84 fun reject_vars thy t =
    85   let
    85   let
    86     val ctxt = ProofContext.init_global thy;
    86     val ctxt = ProofContext.init_global thy;
    87   in ((Sign.no_frees ctxt o Sign.no_vars ctxt o map_types (K dummyT)) t; t) end;
    87   in ((Sign.no_frees ctxt o Sign.no_vars ctxt o map_types (K dummyT)) t; t) end;
    88 
    88 
    89 fun obtain_serializer thy some_target = Code_Target.produce_code_for thy
    89 fun obtain_evaluator thy some_target naming program deps =
    90   (the_default target some_target) NONE "Code" [];
    90   Code_Target.evaluator thy (the_default target some_target) naming program deps;
    91 
    91 
    92 fun base_evaluator cookie serializer (naming : Code_Thingol.naming) thy program ((vs, ty), t) deps args =
    92 fun evaluation cookie thy evaluator vs_t args =
    93   let
    93   let
    94     val ctxt = ProofContext.init_global thy;
    94     val ctxt = ProofContext.init_global thy;
    95     val _ = if Code_Thingol.contains_dict_var t then
    95     val (program_code, value_name) = evaluator vs_t;
    96       error "Term to be evaluated contains free dictionaries" else ();
       
    97     val v' = Name.variant (map fst vs) "a";
       
    98     val vs' = (v', []) :: vs;
       
    99     val ty' = Code_Thingol.fun_tyco `%% [ITyVar v', ty];
       
   100     val value_name = "Value.value.value"
       
   101     val program' = program
       
   102       |> Graph.new_node (value_name,
       
   103           Code_Thingol.Fun (Term.dummy_patternN, (((vs', ty'), [(([IVar NONE], t), (NONE, true))]), NONE)))
       
   104       |> fold (curry Graph.add_edge value_name) deps;
       
   105     val (program_code, [SOME value_name']) = serializer naming program' [value_name];
       
   106     val value_code = space_implode " "
    96     val value_code = space_implode " "
   107       (value_name' :: "()" :: map (enclose "(" ")") args);
    97       (value_name :: "()" :: map (enclose "(" ")") args);
   108   in Exn.interruptible_capture (value ctxt cookie) (program_code, value_code) end;
    98   in Exn.interruptible_capture (value ctxt cookie) (program_code, value_code) end;
   109 
    99 
   110 fun partiality_as_none e = SOME (Exn.release e)
   100 fun partiality_as_none e = SOME (Exn.release e)
   111   handle General.Match => NONE
   101   handle General.Match => NONE
   112     | General.Bind => NONE
   102     | General.Bind => NONE
   117     val _ = reject_vars thy t;
   107     val _ = reject_vars thy t;
   118     val _ = if ! trace
   108     val _ = if ! trace
   119       then tracing ("Evaluation of term " ^ quote (Syntax.string_of_term_global thy t))
   109       then tracing ("Evaluation of term " ^ quote (Syntax.string_of_term_global thy t))
   120       else ()
   110       else ()
   121     fun evaluator naming program ((_, vs_ty), t) deps =
   111     fun evaluator naming program ((_, vs_ty), t) deps =
   122       base_evaluator cookie (obtain_serializer thy some_target) naming thy program (vs_ty, t) deps args;
   112       evaluation cookie thy (obtain_evaluator thy some_target naming program deps) (vs_ty, t) args;
   123   in Code_Thingol.dynamic_value thy (Exn.map_result o postproc) evaluator t end;
   113   in Code_Thingol.dynamic_value thy (Exn.map_result o postproc) evaluator t end;
   124 
   114 
   125 fun dynamic_value_strict cookie thy some_target postproc t args =
   115 fun dynamic_value_strict cookie thy some_target postproc t args =
   126   Exn.release (dynamic_value_exn cookie thy some_target postproc t args);
   116   Exn.release (dynamic_value_exn cookie thy some_target postproc t args);
   127 
   117 
   128 fun dynamic_value cookie thy some_target postproc t args =
   118 fun dynamic_value cookie thy some_target postproc t args =
   129   partiality_as_none (dynamic_value_exn cookie thy some_target postproc t args);
   119   partiality_as_none (dynamic_value_exn cookie thy some_target postproc t args);
   130 
   120 
       
   121 fun static_evaluator cookie thy some_target naming program consts' =
       
   122   let
       
   123     val evaluator = obtain_evaluator thy some_target naming program consts'
       
   124   in fn ((_, vs_ty), t) => fn _ => evaluation cookie thy evaluator (vs_ty, t) [] end;
       
   125 
   131 fun static_value_exn cookie thy some_target postproc consts =
   126 fun static_value_exn cookie thy some_target postproc consts =
   132   let
   127   Code_Thingol.static_value thy (Exn.map_result o postproc) consts
   133     val serializer = obtain_serializer thy some_target;
   128     (static_evaluator cookie thy some_target) o reject_vars thy;
   134     fun evaluator naming program thy ((_, vs_ty), t) deps =
   129 
   135       base_evaluator cookie serializer naming thy program (vs_ty, t) deps [];
   130 fun static_value_strict cookie thy some_target postproc consts =
   136   in Code_Thingol.static_value thy (Exn.map_result o postproc) consts evaluator o reject_vars thy end;
   131   Exn.release o static_value_exn cookie thy some_target postproc consts;
   137 
   132 
   138 fun static_value_strict cookie thy some_target postproc consts t =
   133 fun static_value cookie thy some_target postproc consts =
   139   Exn.release (static_value_exn cookie thy some_target postproc consts t);
   134   partiality_as_none o static_value_exn cookie thy some_target postproc consts;
   140 
       
   141 fun static_value cookie thy some_target postproc consts t =
       
   142   partiality_as_none (static_value_exn cookie thy some_target postproc consts t);
       
   143 
   135 
   144 
   136 
   145 (* evaluation for truth or nothing *)
   137 (* evaluation for truth or nothing *)
   146 
   138 
   147 structure Truth_Result = Proof_Data
   139 structure Truth_Result = Proof_Data
   152 val put_truth = Truth_Result.put;
   144 val put_truth = Truth_Result.put;
   153 val truth_cookie = (Truth_Result.get, put_truth, Long_Name.append this "put_truth");
   145 val truth_cookie = (Truth_Result.get, put_truth, Long_Name.append this "put_truth");
   154 
   146 
   155 val reject_vars = fn thy => tap (reject_vars thy o Thm.term_of);
   147 val reject_vars = fn thy => tap (reject_vars thy o Thm.term_of);
   156 
   148 
   157 fun check_holds serializer naming thy program vs_t deps ct =
   149 fun check_holds some_target naming thy program vs_t deps ct =
   158   let
   150   let
   159     val t = Thm.term_of ct;
   151     val t = Thm.term_of ct;
   160     val _ = if fastype_of t <> propT
   152     val _ = if fastype_of t <> propT
   161       then error ("Not a proposition: " ^ Syntax.string_of_term_global thy t)
   153       then error ("Not a proposition: " ^ Syntax.string_of_term_global thy t)
   162       else ();
   154       else ();
   163     val iff = Thm.cterm_of thy (Term.Const ("==", propT --> propT --> propT));
   155     val iff = Thm.cterm_of thy (Term.Const ("==", propT --> propT --> propT));
   164     val result = case partiality_as_none (base_evaluator truth_cookie serializer naming thy program vs_t deps [])
   156     val result = case partiality_as_none
       
   157       (evaluation truth_cookie thy (obtain_evaluator thy some_target naming program deps) vs_t [])
   165      of SOME Holds => true
   158      of SOME Holds => true
   166       | _ => false;
   159       | _ => false;
   167   in
   160   in
   168     Thm.mk_binop iff ct (if result then @{cprop "PROP Code_Generator.holds"} else ct)
   161     Thm.mk_binop iff ct (if result then @{cprop "PROP Code_Generator.holds"} else ct)
   169   end;
   162   end;
   174 
   167 
   175 fun check_holds_oracle serializer naming thy program ((_, vs_ty), t) deps ct =
   168 fun check_holds_oracle serializer naming thy program ((_, vs_ty), t) deps ct =
   176   raw_check_holds_oracle (serializer, naming, thy, program, (vs_ty, t), deps, ct);
   169   raw_check_holds_oracle (serializer, naming, thy, program, (vs_ty, t), deps, ct);
   177 
   170 
   178 fun dynamic_holds_conv thy = Code_Thingol.dynamic_conv thy
   171 fun dynamic_holds_conv thy = Code_Thingol.dynamic_conv thy
   179     (fn naming => check_holds_oracle (obtain_serializer thy NONE) naming thy)
   172     (fn naming => check_holds_oracle NONE naming thy)
   180   o reject_vars thy;
   173   o reject_vars thy;
   181 
   174 
   182 fun static_holds_conv thy consts =
   175 fun static_holds_conv thy consts =
   183   let
   176   Code_Thingol.static_conv thy consts
   184     val serializer = obtain_serializer thy NONE;
   177     (fn naming => fn program => fn consts' => check_holds_oracle NONE naming thy program)
   185   in
   178     o reject_vars thy;
   186     Code_Thingol.static_conv thy consts
       
   187       (fn naming => fn program => fn thy => check_holds_oracle serializer naming thy program)
       
   188     o reject_vars thy
       
   189   end;
       
   190 
   179 
   191 
   180 
   192 (** instrumentalization **)
   181 (** instrumentalization **)
   193 
   182 
   194 fun evaluation_code thy module_name tycos consts =
   183 fun evaluation_code thy module_name tycos consts =