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 = |