boehmes@36890
|
1 |
(* Title: HOL/Tools/SMT/smt_solver.ML
|
boehmes@36890
|
2 |
Author: Sascha Boehme, TU Muenchen
|
boehmes@36890
|
3 |
|
boehmes@36890
|
4 |
SMT solvers registry and SMT tactic.
|
boehmes@36890
|
5 |
*)
|
boehmes@36890
|
6 |
|
boehmes@36890
|
7 |
signature SMT_SOLVER =
|
boehmes@36890
|
8 |
sig
|
boehmes@40403
|
9 |
datatype failure =
|
boehmes@40403
|
10 |
Counterexample of bool * term list |
|
boehmes@40403
|
11 |
Time_Out |
|
boehmes@40403
|
12 |
Other_Failure of string
|
boehmes@40403
|
13 |
val string_of_failure: Proof.context -> failure -> string
|
boehmes@40403
|
14 |
exception SMT of failure
|
boehmes@36890
|
15 |
|
boehmes@36890
|
16 |
type interface = {
|
boehmes@36890
|
17 |
extra_norm: SMT_Normalize.extra_norm,
|
boehmes@36890
|
18 |
translate: SMT_Translate.config }
|
boehmes@40403
|
19 |
datatype outcome = Unsat | Sat | Unknown
|
boehmes@36890
|
20 |
type solver_config = {
|
boehmes@40403
|
21 |
name: string,
|
boehmes@40403
|
22 |
env_var: string,
|
boehmes@40403
|
23 |
is_remote: bool,
|
boehmes@40403
|
24 |
options: Proof.context -> string list,
|
boehmes@36890
|
25 |
interface: interface,
|
boehmes@40403
|
26 |
outcome: string -> string list -> outcome * string list,
|
boehmes@40403
|
27 |
cex_parser: (Proof.context -> SMT_Translate.recon -> string list ->
|
boehmes@40403
|
28 |
term list) option,
|
boehmes@40403
|
29 |
reconstruct: (Proof.context -> SMT_Translate.recon -> string list ->
|
boehmes@40403
|
30 |
(int list * thm) * Proof.context) option }
|
boehmes@36890
|
31 |
|
boehmes@36890
|
32 |
(*options*)
|
boehmes@40403
|
33 |
val oracle: bool Config.T
|
boehmes@40403
|
34 |
val datatypes: bool Config.T
|
boehmes@36890
|
35 |
val timeout: int Config.T
|
boehmes@36890
|
36 |
val with_timeout: Proof.context -> ('a -> 'b) -> 'a -> 'b
|
boehmes@36890
|
37 |
val trace: bool Config.T
|
boehmes@36890
|
38 |
val trace_msg: Proof.context -> ('a -> string) -> 'a -> unit
|
boehmes@40403
|
39 |
val trace_used_facts: bool Config.T
|
boehmes@36890
|
40 |
|
boehmes@36890
|
41 |
(*certificates*)
|
boehmes@36890
|
42 |
val fixed_certificates: bool Config.T
|
boehmes@36890
|
43 |
val select_certificates: string -> Context.generic -> Context.generic
|
boehmes@36890
|
44 |
|
boehmes@36890
|
45 |
(*solvers*)
|
boehmes@40402
|
46 |
type solver = Proof.context -> (int * thm) list -> int list * thm
|
boehmes@40403
|
47 |
val add_solver: solver_config -> theory -> theory
|
boehmes@40403
|
48 |
val set_solver_options: string -> string -> Context.generic ->
|
boehmes@40403
|
49 |
Context.generic
|
boehmes@36891
|
50 |
val all_solver_names_of: Context.generic -> string list
|
boehmes@36890
|
51 |
val solver_name_of: Context.generic -> string
|
boehmes@36890
|
52 |
val select_solver: string -> Context.generic -> Context.generic
|
boehmes@36890
|
53 |
val solver_of: Context.generic -> solver
|
boehmes@36890
|
54 |
|
boehmes@40403
|
55 |
(*filter*)
|
boehmes@40403
|
56 |
val smt_filter: Proof.state -> int -> ('a * thm) list ->
|
boehmes@40403
|
57 |
'a list * failure option
|
boehmes@40402
|
58 |
|
boehmes@36890
|
59 |
(*tactic*)
|
boehmes@36890
|
60 |
val smt_tac': bool -> Proof.context -> thm list -> int -> Tactical.tactic
|
boehmes@36890
|
61 |
val smt_tac: Proof.context -> thm list -> int -> Tactical.tactic
|
boehmes@36890
|
62 |
|
boehmes@36890
|
63 |
(*setup*)
|
boehmes@36890
|
64 |
val setup: theory -> theory
|
boehmes@36890
|
65 |
val print_setup: Context.generic -> unit
|
boehmes@36890
|
66 |
end
|
boehmes@36890
|
67 |
|
boehmes@36890
|
68 |
structure SMT_Solver: SMT_SOLVER =
|
boehmes@36890
|
69 |
struct
|
boehmes@36890
|
70 |
|
boehmes@40403
|
71 |
datatype failure =
|
boehmes@40403
|
72 |
Counterexample of bool * term list |
|
boehmes@40403
|
73 |
Time_Out |
|
boehmes@40403
|
74 |
Other_Failure of string
|
boehmes@36890
|
75 |
|
boehmes@40403
|
76 |
fun string_of_failure ctxt (Counterexample (real, ex)) =
|
boehmes@40403
|
77 |
let
|
boehmes@40403
|
78 |
val msg = if real then "Counterexample found"
|
boehmes@40403
|
79 |
else "Potential counterexample found"
|
boehmes@40403
|
80 |
in
|
boehmes@40403
|
81 |
if null ex then msg ^ "."
|
boehmes@40403
|
82 |
else Pretty.string_of (Pretty.big_list (msg ^ ":")
|
boehmes@40403
|
83 |
(map (Syntax.pretty_term ctxt) ex))
|
boehmes@40403
|
84 |
end
|
boehmes@40403
|
85 |
| string_of_failure _ Time_Out = "Time out."
|
boehmes@40403
|
86 |
| string_of_failure _ (Other_Failure msg) = msg
|
boehmes@40403
|
87 |
|
boehmes@40403
|
88 |
exception SMT of failure
|
boehmes@36890
|
89 |
|
boehmes@36890
|
90 |
type interface = {
|
boehmes@36890
|
91 |
extra_norm: SMT_Normalize.extra_norm,
|
boehmes@36890
|
92 |
translate: SMT_Translate.config }
|
boehmes@36890
|
93 |
|
boehmes@40403
|
94 |
datatype outcome = Unsat | Sat | Unknown
|
boehmes@40403
|
95 |
|
boehmes@36890
|
96 |
type solver_config = {
|
boehmes@40403
|
97 |
name: string,
|
boehmes@40403
|
98 |
env_var: string,
|
boehmes@40403
|
99 |
is_remote: bool,
|
boehmes@40403
|
100 |
options: Proof.context -> string list,
|
boehmes@36890
|
101 |
interface: interface,
|
boehmes@40403
|
102 |
outcome: string -> string list -> outcome * string list,
|
boehmes@40403
|
103 |
cex_parser: (Proof.context -> SMT_Translate.recon -> string list ->
|
boehmes@40403
|
104 |
term list) option,
|
boehmes@40403
|
105 |
reconstruct: (Proof.context -> SMT_Translate.recon -> string list ->
|
boehmes@40403
|
106 |
(int list * thm) * Proof.context) option }
|
boehmes@36890
|
107 |
|
boehmes@36890
|
108 |
|
boehmes@36890
|
109 |
|
boehmes@36890
|
110 |
(* SMT options *)
|
boehmes@36890
|
111 |
|
boehmes@40403
|
112 |
val (oracle, setup_oracle) = Attrib.config_bool "smt_oracle" (K true)
|
boehmes@40403
|
113 |
|
boehmes@40403
|
114 |
val (datatypes, setup_datatypes) = Attrib.config_bool "smt_datatypes" (K false)
|
boehmes@40403
|
115 |
|
boehmes@36890
|
116 |
val (timeout, setup_timeout) = Attrib.config_int "smt_timeout" (K 30)
|
boehmes@36890
|
117 |
|
boehmes@36890
|
118 |
fun with_timeout ctxt f x =
|
boehmes@36890
|
119 |
TimeLimit.timeLimit (Time.fromSeconds (Config.get ctxt timeout)) f x
|
boehmes@40403
|
120 |
handle TimeLimit.TimeOut => raise SMT Time_Out
|
boehmes@36890
|
121 |
|
boehmes@36890
|
122 |
val (trace, setup_trace) = Attrib.config_bool "smt_trace" (K false)
|
boehmes@36890
|
123 |
|
boehmes@36890
|
124 |
fun trace_msg ctxt f x =
|
boehmes@36890
|
125 |
if Config.get ctxt trace then tracing (f x) else ()
|
boehmes@36890
|
126 |
|
boehmes@40403
|
127 |
val (trace_used_facts, setup_trace_used_facts) =
|
boehmes@40403
|
128 |
Attrib.config_bool "smt_trace_used_facts" (K false)
|
boehmes@36890
|
129 |
|
boehmes@36890
|
130 |
|
boehmes@36890
|
131 |
(* SMT certificates *)
|
boehmes@36890
|
132 |
|
boehmes@36890
|
133 |
val (fixed_certificates, setup_fixed_certificates) =
|
boehmes@36890
|
134 |
Attrib.config_bool "smt_fixed" (K false)
|
boehmes@36890
|
135 |
|
boehmes@36890
|
136 |
structure Certificates = Generic_Data
|
boehmes@36890
|
137 |
(
|
boehmes@36890
|
138 |
type T = Cache_IO.cache option
|
boehmes@36890
|
139 |
val empty = NONE
|
boehmes@36890
|
140 |
val extend = I
|
boehmes@36890
|
141 |
fun merge (s, _) = s
|
boehmes@36890
|
142 |
)
|
boehmes@36890
|
143 |
|
boehmes@36890
|
144 |
val get_certificates_path =
|
boehmes@36890
|
145 |
Option.map (Cache_IO.cache_path_of) o Certificates.get
|
boehmes@36890
|
146 |
|
boehmes@36890
|
147 |
fun select_certificates name = Certificates.put (
|
boehmes@36890
|
148 |
if name = "" then NONE
|
boehmes@36890
|
149 |
else SOME (Cache_IO.make (Path.explode name)))
|
boehmes@36890
|
150 |
|
boehmes@36890
|
151 |
|
boehmes@36890
|
152 |
|
boehmes@36890
|
153 |
(* interface to external solvers *)
|
boehmes@36890
|
154 |
|
boehmes@36890
|
155 |
local
|
boehmes@36890
|
156 |
|
boehmes@40403
|
157 |
fun choose (env_var, is_remote, remote_name) =
|
boehmes@36890
|
158 |
let
|
boehmes@36890
|
159 |
val local_solver = getenv env_var
|
boehmes@36890
|
160 |
val remote_url = getenv "REMOTE_SMT_URL"
|
boehmes@36890
|
161 |
in
|
boehmes@36890
|
162 |
if local_solver <> ""
|
boehmes@36890
|
163 |
then
|
boehmes@36890
|
164 |
(tracing ("Invoking local SMT solver " ^ quote local_solver ^ " ...");
|
boehmes@36890
|
165 |
[local_solver])
|
boehmes@40403
|
166 |
else if is_remote
|
boehmes@36890
|
167 |
then
|
boehmes@40403
|
168 |
(tracing ("Invoking remote SMT solver " ^ quote remote_name ^ " at " ^
|
boehmes@36890
|
169 |
quote remote_url ^ " ...");
|
boehmes@40403
|
170 |
[getenv "REMOTE_SMT", remote_name])
|
boehmes@36890
|
171 |
else error ("Undefined Isabelle environment variable: " ^ quote env_var)
|
boehmes@36890
|
172 |
end
|
boehmes@36890
|
173 |
|
boehmes@36890
|
174 |
fun make_cmd solver args problem_path proof_path = space_implode " " (
|
boehmes@36890
|
175 |
map File.shell_quote (solver @ args) @
|
boehmes@36890
|
176 |
[File.shell_path problem_path, "2>&1", ">", File.shell_path proof_path])
|
boehmes@36890
|
177 |
|
boehmes@36890
|
178 |
fun run ctxt cmd args input =
|
boehmes@36890
|
179 |
(case Certificates.get (Context.Proof ctxt) of
|
boehmes@36890
|
180 |
NONE => Cache_IO.run (make_cmd (choose cmd) args) input
|
boehmes@36890
|
181 |
| SOME certs =>
|
boehmes@36890
|
182 |
(case Cache_IO.lookup certs input of
|
boehmes@36890
|
183 |
(NONE, key) =>
|
boehmes@36890
|
184 |
if Config.get ctxt fixed_certificates
|
boehmes@36890
|
185 |
then error ("Bad certificates cache: missing certificate")
|
boehmes@36890
|
186 |
else Cache_IO.run_and_cache certs key (make_cmd (choose cmd) args)
|
boehmes@36890
|
187 |
input
|
boehmes@36890
|
188 |
| (SOME output, _) =>
|
boehmes@36890
|
189 |
(tracing ("Using cached certificate from " ^
|
boehmes@36890
|
190 |
File.shell_path (Cache_IO.cache_path_of certs) ^ " ...");
|
boehmes@36890
|
191 |
output)))
|
boehmes@36890
|
192 |
|
boehmes@36890
|
193 |
in
|
boehmes@36890
|
194 |
|
boehmes@36890
|
195 |
fun run_solver ctxt cmd args input =
|
boehmes@36890
|
196 |
let
|
boehmes@36890
|
197 |
fun pretty tag ls = Pretty.string_of (Pretty.big_list tag
|
boehmes@36890
|
198 |
(map Pretty.str ls))
|
boehmes@36890
|
199 |
|
boehmes@36890
|
200 |
val _ = trace_msg ctxt (pretty "SMT problem:" o split_lines) input
|
boehmes@36890
|
201 |
|
boehmes@36890
|
202 |
val (res, err) = with_timeout ctxt (run ctxt cmd args) input
|
boehmes@36890
|
203 |
val _ = trace_msg ctxt (pretty "SMT solver:") err
|
boehmes@36890
|
204 |
|
haftmann@40057
|
205 |
val ls = rev (snd (chop_while (equal "") (rev res)))
|
boehmes@36890
|
206 |
val _ = trace_msg ctxt (pretty "SMT result:") ls
|
boehmes@36890
|
207 |
in ls end
|
boehmes@36890
|
208 |
|
boehmes@36890
|
209 |
end
|
boehmes@36890
|
210 |
|
blanchet@36933
|
211 |
fun trace_recon_data ctxt ({typs, terms, ...} : SMT_Translate.recon) =
|
boehmes@36890
|
212 |
let
|
boehmes@36890
|
213 |
fun pretty_eq n p = Pretty.block [Pretty.str n, Pretty.str " = ", p]
|
boehmes@36890
|
214 |
fun pretty_typ (n, T) = pretty_eq n (Syntax.pretty_typ ctxt T)
|
boehmes@36890
|
215 |
fun pretty_term (n, t) = pretty_eq n (Syntax.pretty_term ctxt t)
|
boehmes@36890
|
216 |
in
|
boehmes@36890
|
217 |
trace_msg ctxt (fn () => Pretty.string_of (Pretty.big_list "SMT names:" [
|
boehmes@36890
|
218 |
Pretty.big_list "sorts:" (map pretty_typ (Symtab.dest typs)),
|
boehmes@36890
|
219 |
Pretty.big_list "functions:" (map pretty_term (Symtab.dest terms))])) ()
|
boehmes@36890
|
220 |
end
|
boehmes@36890
|
221 |
|
boehmes@40403
|
222 |
fun invoke translate_config name cmd more_opts options irules ctxt =
|
boehmes@40403
|
223 |
let
|
boehmes@40403
|
224 |
val args = more_opts @ options ctxt
|
boehmes@40403
|
225 |
val comments = ("solver: " ^ name) ::
|
boehmes@40403
|
226 |
("timeout: " ^ string_of_int (Config.get ctxt timeout)) ::
|
boehmes@40403
|
227 |
"arguments:" :: args
|
boehmes@40403
|
228 |
in
|
boehmes@40403
|
229 |
irules
|
boehmes@40403
|
230 |
|> SMT_Translate.translate translate_config ctxt comments
|
boehmes@40403
|
231 |
||> tap (trace_recon_data ctxt)
|
boehmes@40403
|
232 |
|>> run_solver ctxt cmd args
|
boehmes@40403
|
233 |
|> rpair ctxt
|
boehmes@40403
|
234 |
end
|
boehmes@36890
|
235 |
|
boehmes@36890
|
236 |
fun discharge_definitions thm =
|
boehmes@36890
|
237 |
if Thm.nprems_of thm = 0 then thm
|
boehmes@36890
|
238 |
else discharge_definitions (@{thm reflexive} RS thm)
|
boehmes@36890
|
239 |
|
boehmes@40403
|
240 |
fun set_has_datatypes with_datatypes translate =
|
boehmes@36890
|
241 |
let
|
boehmes@40403
|
242 |
val {prefixes, header, strict, builtins, serialize} = translate
|
boehmes@40403
|
243 |
val {builtin_typ, builtin_num, builtin_fun, has_datatypes} = builtins
|
boehmes@40403
|
244 |
val with_datatypes' = has_datatypes andalso with_datatypes
|
boehmes@40403
|
245 |
val builtins' = {builtin_typ=builtin_typ, builtin_num=builtin_num,
|
boehmes@40403
|
246 |
builtin_fun=builtin_fun, has_datatypes=with_datatypes}
|
boehmes@40403
|
247 |
val translate' = {prefixes=prefixes, header=header, strict=strict,
|
boehmes@40403
|
248 |
builtins=builtins', serialize=serialize}
|
boehmes@40403
|
249 |
in (with_datatypes', translate') end
|
boehmes@40403
|
250 |
|
boehmes@40403
|
251 |
fun gen_solver name info ctxt irules =
|
boehmes@40403
|
252 |
let
|
boehmes@40403
|
253 |
val {env_var, is_remote, options, more_options, interface, reconstruct} =
|
boehmes@40403
|
254 |
info
|
boehmes@36890
|
255 |
val {extra_norm, translate} = interface
|
boehmes@40403
|
256 |
val (with_datatypes, translate') =
|
boehmes@40403
|
257 |
set_has_datatypes (Config.get ctxt datatypes) translate
|
boehmes@36890
|
258 |
in
|
boehmes@40403
|
259 |
(irules, ctxt)
|
boehmes@40403
|
260 |
|-> SMT_Normalize.normalize extra_norm with_datatypes
|
boehmes@40403
|
261 |
|-> invoke translate' name (env_var, is_remote, name) more_options options
|
boehmes@36890
|
262 |
|-> reconstruct
|
boehmes@40402
|
263 |
|-> (fn (idxs, thm) => fn ctxt' => thm
|
boehmes@36890
|
264 |
|> singleton (ProofContext.export ctxt' ctxt)
|
boehmes@40402
|
265 |
|> discharge_definitions
|
boehmes@40402
|
266 |
|> pair idxs)
|
boehmes@36890
|
267 |
end
|
boehmes@36890
|
268 |
|
boehmes@36890
|
269 |
|
boehmes@36890
|
270 |
|
boehmes@36890
|
271 |
(* solver store *)
|
boehmes@36890
|
272 |
|
boehmes@40402
|
273 |
type solver = Proof.context -> (int * thm) list -> int list * thm
|
boehmes@40403
|
274 |
|
boehmes@40403
|
275 |
type solver_info = {
|
boehmes@40403
|
276 |
env_var: string,
|
boehmes@40403
|
277 |
is_remote: bool,
|
boehmes@40403
|
278 |
options: Proof.context -> string list,
|
boehmes@40403
|
279 |
more_options: string list,
|
boehmes@40403
|
280 |
interface: interface,
|
boehmes@40403
|
281 |
reconstruct: string list * SMT_Translate.recon -> Proof.context ->
|
boehmes@40403
|
282 |
(int list * thm) * Proof.context }
|
boehmes@36890
|
283 |
|
boehmes@36891
|
284 |
structure Solvers = Generic_Data
|
boehmes@36890
|
285 |
(
|
boehmes@40403
|
286 |
type T = solver_info Symtab.table
|
boehmes@36890
|
287 |
val empty = Symtab.empty
|
boehmes@36890
|
288 |
val extend = I
|
boehmes@36890
|
289 |
fun merge data = Symtab.merge (K true) data
|
boehmes@36890
|
290 |
handle Symtab.DUP name => error ("Duplicate SMT solver: " ^ quote name)
|
boehmes@36890
|
291 |
)
|
boehmes@36890
|
292 |
|
boehmes@36890
|
293 |
val no_solver = "(none)"
|
boehmes@40403
|
294 |
|
boehmes@40403
|
295 |
fun set_solver_options name opts = Solvers.map (Symtab.map_entry name (fn
|
boehmes@40403
|
296 |
{env_var, is_remote, options, interface, reconstruct, ...} =>
|
boehmes@40403
|
297 |
{env_var=env_var, is_remote=is_remote, options=options,
|
boehmes@40403
|
298 |
more_options=String.tokens (Symbol.is_ascii_blank o str) opts,
|
boehmes@40403
|
299 |
interface=interface, reconstruct=reconstruct}))
|
boehmes@40403
|
300 |
|
boehmes@40403
|
301 |
local
|
boehmes@40403
|
302 |
fun finish outcome cex_parser reconstruct ocl (output, recon) ctxt =
|
boehmes@40403
|
303 |
(case outcome output of
|
boehmes@40403
|
304 |
(Unsat, ls) =>
|
boehmes@40403
|
305 |
if not (Config.get ctxt oracle) andalso is_some reconstruct
|
boehmes@40403
|
306 |
then the reconstruct ctxt recon ls
|
boehmes@40403
|
307 |
else (([], ocl ()), ctxt)
|
boehmes@40403
|
308 |
| (result, ls) =>
|
boehmes@40403
|
309 |
let val ts = (case cex_parser of SOME f => f ctxt recon ls | _ => [])
|
boehmes@40403
|
310 |
in raise SMT (Counterexample (result = Sat, ts)) end)
|
boehmes@40403
|
311 |
in
|
boehmes@40403
|
312 |
|
boehmes@40403
|
313 |
fun add_solver cfg =
|
boehmes@40403
|
314 |
let
|
boehmes@40403
|
315 |
val {name, env_var, is_remote, options, interface, outcome, cex_parser,
|
boehmes@40403
|
316 |
reconstruct} = cfg
|
boehmes@40403
|
317 |
|
boehmes@40403
|
318 |
fun core_oracle () = @{cprop False}
|
boehmes@40403
|
319 |
|
boehmes@40403
|
320 |
fun solver ocl = { env_var=env_var, is_remote=is_remote, options=options,
|
boehmes@40403
|
321 |
more_options=[], interface=interface,
|
boehmes@40403
|
322 |
reconstruct=finish (outcome name) cex_parser reconstruct ocl }
|
boehmes@40403
|
323 |
in
|
boehmes@40403
|
324 |
Thm.add_oracle (Binding.name name, core_oracle) #-> (fn (_, ocl) =>
|
boehmes@40403
|
325 |
Context.theory_map (Solvers.map (Symtab.update_new (name, solver ocl)))) #>
|
boehmes@40403
|
326 |
Attrib.setup (Binding.name (name ^ "_options"))
|
boehmes@40403
|
327 |
(Scan.lift (Parse.$$$ "=" |-- Args.name) >>
|
boehmes@40403
|
328 |
(Thm.declaration_attribute o K o set_solver_options name))
|
boehmes@40403
|
329 |
("Additional command line options for SMT solver " ^ quote name)
|
boehmes@40403
|
330 |
end
|
boehmes@40403
|
331 |
|
boehmes@40403
|
332 |
end
|
boehmes@40403
|
333 |
|
boehmes@36890
|
334 |
val all_solver_names_of = Symtab.keys o Solvers.get
|
boehmes@36890
|
335 |
val lookup_solver = Symtab.lookup o Solvers.get
|
boehmes@36890
|
336 |
|
boehmes@36890
|
337 |
|
boehmes@36890
|
338 |
|
boehmes@36890
|
339 |
(* selected solver *)
|
boehmes@36890
|
340 |
|
boehmes@36890
|
341 |
structure Selected_Solver = Generic_Data
|
boehmes@36890
|
342 |
(
|
boehmes@36890
|
343 |
type T = string
|
boehmes@36890
|
344 |
val empty = no_solver
|
boehmes@36890
|
345 |
val extend = I
|
boehmes@36890
|
346 |
fun merge (s, _) = s
|
boehmes@36890
|
347 |
)
|
boehmes@36890
|
348 |
|
boehmes@36890
|
349 |
val solver_name_of = Selected_Solver.get
|
boehmes@36890
|
350 |
|
boehmes@36890
|
351 |
fun select_solver name context =
|
boehmes@36891
|
352 |
if is_none (lookup_solver context name)
|
boehmes@36890
|
353 |
then error ("SMT solver not registered: " ^ quote name)
|
boehmes@36890
|
354 |
else Selected_Solver.map (K name) context
|
boehmes@36890
|
355 |
|
boehmes@36890
|
356 |
fun raw_solver_of context name =
|
boehmes@36891
|
357 |
(case lookup_solver context name of
|
boehmes@36890
|
358 |
NONE => error "No SMT solver selected"
|
boehmes@40403
|
359 |
| SOME s => s)
|
boehmes@36890
|
360 |
|
boehmes@36890
|
361 |
fun solver_of context =
|
boehmes@36890
|
362 |
let val name = solver_name_of context
|
boehmes@36890
|
363 |
in gen_solver name (raw_solver_of context name) end
|
boehmes@36890
|
364 |
|
boehmes@36890
|
365 |
|
boehmes@36890
|
366 |
|
boehmes@40403
|
367 |
(* SMT filter *)
|
boehmes@40402
|
368 |
|
boehmes@40402
|
369 |
val has_topsort = Term.exists_type (Term.exists_subtype (fn
|
boehmes@40402
|
370 |
TFree (_, []) => true
|
boehmes@40402
|
371 |
| TVar (_, []) => true
|
boehmes@40402
|
372 |
| _ => false))
|
boehmes@40402
|
373 |
|
boehmes@40403
|
374 |
fun smt_solver ctxt irules =
|
boehmes@40402
|
375 |
(* without this test, we would run into problems when atomizing the rules: *)
|
boehmes@40403
|
376 |
if exists (has_topsort o Thm.prop_of o snd) irules
|
boehmes@40403
|
377 |
then raise SMT (Other_Failure "proof state contains the universal sort {}")
|
boehmes@40403
|
378 |
else solver_of (Context.Proof ctxt) ctxt irules
|
boehmes@40403
|
379 |
|
boehmes@40403
|
380 |
fun smt_filter st i xrules =
|
boehmes@40403
|
381 |
let
|
boehmes@40403
|
382 |
val {context, facts, goal} = Proof.goal st
|
boehmes@40403
|
383 |
val cprop =
|
boehmes@40403
|
384 |
Thm.cprem_of goal i
|
boehmes@40403
|
385 |
|> Thm.rhs_of o SMT_Normalize.atomize_conv context
|
boehmes@40403
|
386 |
|> Thm.capply @{cterm Trueprop} o Thm.capply @{cterm Not} o Thm.dest_arg
|
boehmes@40403
|
387 |
val irs = map (pair ~1) (Thm.assume cprop :: facts)
|
boehmes@40403
|
388 |
in
|
boehmes@40402
|
389 |
split_list xrules
|
boehmes@40403
|
390 |
||>> solver_of (Context.Proof context) context o append irs o map_index I
|
boehmes@40402
|
391 |
|>> uncurry (map_filter o try o nth) o apsnd (distinct (op =))
|
boehmes@40403
|
392 |
|> rpair NONE o fst
|
boehmes@40403
|
393 |
end
|
boehmes@40403
|
394 |
handle SMT fail => ([], SOME fail)
|
boehmes@40402
|
395 |
|
boehmes@40402
|
396 |
|
boehmes@40402
|
397 |
|
boehmes@36890
|
398 |
(* SMT tactic *)
|
boehmes@36890
|
399 |
|
boehmes@36890
|
400 |
local
|
boehmes@36890
|
401 |
fun fail_tac f msg st = (f msg; Tactical.no_tac st)
|
boehmes@36890
|
402 |
|
boehmes@36890
|
403 |
fun SAFE pass_exns tac ctxt i st =
|
boehmes@36890
|
404 |
if pass_exns then tac ctxt i st
|
boehmes@40403
|
405 |
else (tac ctxt i st handle SMT fail => fail_tac
|
boehmes@40403
|
406 |
(trace_msg ctxt (prefix "SMT: ") o string_of_failure ctxt) fail st)
|
boehmes@36890
|
407 |
in
|
boehmes@40403
|
408 |
|
boehmes@36890
|
409 |
fun smt_tac' pass_exns ctxt rules =
|
boehmes@36891
|
410 |
CONVERSION (SMT_Normalize.atomize_conv ctxt)
|
boehmes@36891
|
411 |
THEN' Tactic.rtac @{thm ccontr}
|
boehmes@36891
|
412 |
THEN' SUBPROOF (fn {context, prems, ...} =>
|
boehmes@40403
|
413 |
let fun solve cx = snd (smt_solver cx (map (pair ~1) (rules @ prems)))
|
boehmes@40402
|
414 |
in SAFE pass_exns (Tactic.rtac o solve) context 1 end) ctxt
|
boehmes@36890
|
415 |
|
boehmes@36890
|
416 |
val smt_tac = smt_tac' false
|
boehmes@40403
|
417 |
|
boehmes@36890
|
418 |
end
|
boehmes@36890
|
419 |
|
boehmes@36890
|
420 |
val smt_method =
|
boehmes@36890
|
421 |
Scan.optional Attrib.thms [] >>
|
boehmes@36890
|
422 |
(fn thms => fn ctxt => METHOD (fn facts =>
|
boehmes@36890
|
423 |
HEADGOAL (smt_tac ctxt (thms @ facts))))
|
boehmes@36890
|
424 |
|
boehmes@36890
|
425 |
|
boehmes@36890
|
426 |
|
boehmes@36890
|
427 |
(* setup *)
|
boehmes@36890
|
428 |
|
boehmes@36890
|
429 |
val setup =
|
wenzelm@39075
|
430 |
Attrib.setup @{binding smt_solver}
|
wenzelm@36970
|
431 |
(Scan.lift (Parse.$$$ "=" |-- Args.name) >>
|
boehmes@36890
|
432 |
(Thm.declaration_attribute o K o select_solver))
|
boehmes@36890
|
433 |
"SMT solver configuration" #>
|
boehmes@40403
|
434 |
setup_oracle #>
|
boehmes@40403
|
435 |
setup_datatypes #>
|
boehmes@36890
|
436 |
setup_timeout #>
|
boehmes@36890
|
437 |
setup_trace #>
|
boehmes@40403
|
438 |
setup_trace_used_facts #>
|
boehmes@36890
|
439 |
setup_fixed_certificates #>
|
wenzelm@39075
|
440 |
Attrib.setup @{binding smt_certificates}
|
wenzelm@36970
|
441 |
(Scan.lift (Parse.$$$ "=" |-- Args.name) >>
|
boehmes@36890
|
442 |
(Thm.declaration_attribute o K o select_certificates))
|
boehmes@36890
|
443 |
"SMT certificates" #>
|
wenzelm@39075
|
444 |
Method.setup @{binding smt} smt_method
|
boehmes@36890
|
445 |
"Applies an SMT solver to the current goal."
|
boehmes@36890
|
446 |
|
boehmes@36890
|
447 |
|
boehmes@36891
|
448 |
fun print_setup context =
|
boehmes@36890
|
449 |
let
|
boehmes@36891
|
450 |
val t = string_of_int (Config.get_generic context timeout)
|
boehmes@36891
|
451 |
val names = sort_strings (all_solver_names_of context)
|
boehmes@36890
|
452 |
val ns = if null names then [no_solver] else names
|
boehmes@40403
|
453 |
val n = solver_name_of context
|
boehmes@40403
|
454 |
val opts =
|
boehmes@40403
|
455 |
(case Symtab.lookup (Solvers.get context) n of
|
boehmes@40403
|
456 |
NONE => []
|
boehmes@40403
|
457 |
| SOME {more_options, options, ...} =>
|
boehmes@40403
|
458 |
more_options @ options (Context.proof_of context))
|
boehmes@36890
|
459 |
val certs_filename =
|
boehmes@36891
|
460 |
(case get_certificates_path context of
|
boehmes@36890
|
461 |
SOME path => Path.implode path
|
boehmes@36890
|
462 |
| NONE => "(disabled)")
|
boehmes@36891
|
463 |
val fixed = if Config.get_generic context fixed_certificates then "true"
|
boehmes@36890
|
464 |
else "false"
|
boehmes@36890
|
465 |
in
|
boehmes@36890
|
466 |
Pretty.writeln (Pretty.big_list "SMT setup:" [
|
boehmes@40403
|
467 |
Pretty.str ("Current SMT solver: " ^ n),
|
boehmes@40403
|
468 |
Pretty.str ("Current SMT solver options: " ^ space_implode " " opts),
|
boehmes@36890
|
469 |
Pretty.str_list "Available SMT solvers: " "" ns,
|
boehmes@36890
|
470 |
Pretty.str ("Current timeout: " ^ t ^ " seconds"),
|
boehmes@40403
|
471 |
Pretty.str ("With proofs: " ^
|
boehmes@40403
|
472 |
(if Config.get_generic context oracle then "false" else "true")),
|
boehmes@36890
|
473 |
Pretty.str ("Certificates cache: " ^ certs_filename),
|
boehmes@40403
|
474 |
Pretty.str ("Fixed certificates: " ^ fixed)])
|
boehmes@36890
|
475 |
end
|
boehmes@36890
|
476 |
|
wenzelm@36970
|
477 |
val _ =
|
wenzelm@36970
|
478 |
Outer_Syntax.improper_command "smt_status"
|
boehmes@40402
|
479 |
"show the available SMT solvers and the currently selected solver"
|
boehmes@40402
|
480 |
Keyword.diag
|
boehmes@36890
|
481 |
(Scan.succeed (Toplevel.no_timing o Toplevel.keep (fn state =>
|
boehmes@36890
|
482 |
print_setup (Context.Proof (Toplevel.context_of state)))))
|
boehmes@36890
|
483 |
|
boehmes@36890
|
484 |
end
|