diff --git a/sledge/bin/sledge_cli.ml b/sledge/bin/sledge_cli.ml
index 9621e2300..3e5228c04 100644
--- a/sledge/bin/sledge_cli.ml
+++ b/sledge/bin/sledge_cli.ml
@@ -45,19 +45,26 @@ let command ~summary ?readme param =
Trace.flush () ;
Format.printf "@\nRESULT: Success: Invalid Accesses: %i@."
(Report.invalid_access_count ())
- with exn ->
- let bt = Printexc.get_raw_backtrace () in
- Trace.flush () ;
- ( match exn with
- | Frontend.Invalid_llvm msg ->
- Format.printf "@\nRESULT: Invalid input: %s@." msg
- | Unimplemented msg ->
- Format.printf "@\nRESULT: Unimplemented: %s@." msg
- | Failure msg -> Format.printf "@\nRESULT: Internal error: %s@." msg
- | _ ->
- Format.printf "@\nRESULT: Unknown error: %s@."
- (Printexc.to_string exn) ) ;
- Printexc.raise_with_backtrace exn bt
+ with
+ | Smtlib.Unsound ->
+ Trace.flush () ;
+ Format.printf "@\nRESULT: Unsound@."
+ | Smtlib.Incomplete ->
+ Trace.flush () ;
+ Format.printf "@\nRESULT: Incomplete@."
+ | exn ->
+ let bt = Printexc.get_raw_backtrace () in
+ Trace.flush () ;
+ ( match exn with
+ | Frontend.Invalid_llvm msg ->
+ Format.printf "@\nRESULT: Invalid input: %s@." msg
+ | Unimplemented msg ->
+ Format.printf "@\nRESULT: Unimplemented: %s@." msg
+ | Failure msg -> Format.printf "@\nRESULT: Internal error: %s@." msg
+ | _ ->
+ Format.printf "@\nRESULT: Unknown error: %s@."
+ (Printexc.to_string exn) ) ;
+ Printexc.raise_with_backtrace exn bt
in
Command.basic ~summary ?readme (trace *> param >>| wrap)
@@ -230,6 +237,17 @@ let disassemble_cmd =
in
command ~summary ~readme param
+let smt_cmd =
+ let summary = "process SMT-LIB benchmarks" in
+ let readme () =
+ "The file is interpreted as an SMT-LIB 2 benchmark."
+ in
+ let param =
+ let%map_open input = anon ("" %: string) in
+ fun () -> Smtlib.process input
+ in
+ command ~summary ~readme param
+
let summary = "SLEdge static analyzer"
let readme () =
@@ -245,4 +263,5 @@ Command.run ~version:Version.version ~build_info:Version.build_info
[ ("buck", Sledge_buck.main ~command ~analyze:(translate >*> analyze))
; ("llvm", llvm_grp)
; ("analyze", analyze_cmd)
- ; ("disassemble", disassemble_cmd) ])
+ ; ("disassemble", disassemble_cmd)
+ ; ("smt", smt_cmd) ])
diff --git a/sledge/bin/smtlib.ml b/sledge/bin/smtlib.ml
new file mode 100644
index 000000000..60c7fa17b
--- /dev/null
+++ b/sledge/bin/smtlib.ml
@@ -0,0 +1,186 @@
+(*
+ * Copyright (c) Facebook, Inc. and its affiliates.
+ *
+ * This source code is licensed under the MIT license found in the
+ * LICENSE file in the root directory of this source tree.
+ *)
+
+(** Process SMT-LIB benchmarks using SLEdge's first-order theory solver. *)
+
+module Smt = Smtlib_utils.V_2_6
+open Fol
+module VarEnv = Map.Make (String)
+
+type var_env = Term.t VarEnv.t
+type frame = {mutable asserts: Smt.Ast.term list; mutable var_env: var_env}
+
+let init_stack = [{asserts= []; var_env= VarEnv.empty}]
+let stack = ref init_stack
+let top () = List.hd_exn !stack
+
+let push () =
+ let {asserts; var_env} = top () in
+ stack := {asserts; var_env} :: !stack
+
+let pop () =
+ match !stack with
+ | [] -> assert false
+ | [_] -> ()
+ | _ :: tl -> stack := tl
+
+let reset () = stack := init_stack
+
+let id =
+ let count = ref (-1) in
+ fun () ->
+ incr count ;
+ !count
+
+let decl_var name =
+ let v = Term.var (Var.identified ~name ~id:(id ())) in
+ let top = top () in
+ top.var_env <- VarEnv.add_exn ~key:name ~data:v top.var_env
+
+let assert_term term =
+ let top = top () in
+ top.asserts <- term :: top.asserts
+
+let rec x_let init nes =
+ List.fold nes ~init ~f:(fun n (name, term) ->
+ VarEnv.add_exn ~key:name ~data:(x_trm init term) n )
+
+and x_trm : var_env -> Smt.Ast.term -> Term.t =
+ fun n term ->
+ match term with
+ | Const s -> (
+ try VarEnv.find_exn n s
+ with _ -> (
+ try Term.rational (Q.of_string s)
+ with _ -> (
+ try Term.rational (Q.of_float (Float.of_string s))
+ with _ -> fail "not a rational: %a" Smt.Ast.pp_term term () ) ) )
+ | Arith (Add, e :: es) ->
+ List.fold ~f:(fun s e -> Term.add s (x_trm n e)) ~init:(x_trm n e) es
+ | Arith (Minus, e :: es) ->
+ List.fold ~f:(fun s e -> Term.sub s (x_trm n e)) ~init:(x_trm n e) es
+ | Arith (Mult, es) -> (
+ match List.map ~f:(x_trm n) es with
+ | e :: es ->
+ List.fold es ~init:e ~f:(fun p e ->
+ match Term.const_of e with
+ | Some q -> Term.mulq q p
+ | None -> (
+ match Term.const_of p with
+ | Some q -> Term.mulq q e
+ | None -> fail "nonlinear: %a" Smt.Ast.pp_term term () ) )
+ | [] -> fail "malformed: %a" Smt.Ast.pp_term term () )
+ | Arith (Div, es) -> (
+ match List.map ~f:(x_trm n) es with
+ | e :: es ->
+ List.fold es ~init:e ~f:(fun p e ->
+ match Term.const_of e with
+ | Some q -> Term.mulq (Q.inv q) p
+ | None -> fail "nonlinear: %a" Smt.Ast.pp_term term () )
+ | [] -> fail "malformed: %a" Smt.Ast.pp_term term () )
+ | If (c, t, e) ->
+ Term.ite ~cnd:(x_fml n c) ~thn:(x_trm n t) ~els:(x_trm n e)
+ | App _ -> todo "%a" Smt.Ast.pp_term term ()
+ | Let (nes, e) -> x_trm (x_let n nes) e
+ | Attr (e, _) -> x_trm n e
+ | Fun _ | HO_app _ -> fail "higher-order: %a" Smt.Ast.pp_term term ()
+ | Match _ -> fail "datatype: %a" Smt.Ast.pp_term term ()
+ | Cast _ -> fail "cast: %a" Smt.Ast.pp_term term ()
+ | Arith ((Add | Minus), _) -> fail "malformed: %a" Smt.Ast.pp_term term ()
+ | True | False
+ |Arith ((Leq | Lt | Geq | Gt), _)
+ |Is_a _ | Eq _ | Imply _ | And _ | Or _ | Not _ | Distinct _ | Forall _
+ |Exists _ ->
+ Formula.inject (x_fml n term)
+
+and x_fml : var_env -> Smt.Ast.term -> Formula.t =
+ fun n term ->
+ match term with
+ | True -> Formula.tt
+ | False -> Formula.ff
+ | If (cnd, pos, neg) ->
+ Formula.cond ~cnd:(x_fml n cnd) ~pos:(x_fml n pos) ~neg:(x_fml n neg)
+ | App _ -> todo "%a" Smt.Ast.pp_term term ()
+ | Let (nes, b) -> x_fml (x_let n nes) b
+ | Eq (d, e) -> Formula.eq (x_trm n d) (x_trm n e)
+ | Imply (a, b) -> x_fml n (Or [Not a; b])
+ | And bs -> Formula.andN (List.map ~f:(x_fml n) bs)
+ | Or bs -> Formula.orN (List.map ~f:(x_fml n) bs)
+ | Distinct es ->
+ es
+ |> List.map ~f:(x_trm n)
+ |> Iter.diagonal_l
+ |> Iter.map ~f:(fun (d, e) -> Formula.dq d e)
+ |> Iter.to_list
+ |> Formula.andN
+ | Not b -> Formula.not_ (x_fml n b)
+ | Attr (b, _) -> x_fml n b
+ | Cast _ -> fail "cast: %a" Smt.Ast.pp_term term ()
+ | Arith ((Leq | Lt | Geq | Gt), _) ->
+ fail "inequality: %a" Smt.Ast.pp_term term ()
+ | Fun _ | HO_app _ -> fail "higher-order: %a" Smt.Ast.pp_term term ()
+ | Match _ | Is_a _ -> fail "datatype: %a" Smt.Ast.pp_term term ()
+ | Forall _ | Exists _ -> fail "quantifier: %a" Smt.Ast.pp_term term ()
+ | Const _ | Arith ((Add | Minus | Mult | Div), _) ->
+ Formula.dq0 (x_trm n term)
+
+let x_context {asserts; var_env} =
+ Context.dnf (Formula.andN (List.map ~f:(x_fml var_env) asserts))
+
+let check_unsat (_, asserts, ctx) =
+ [%Trace.call fun {pf} ->
+ pf "%a@ %a@ %a" Formula.pp asserts Context.pp ctx Context.pp_raw ctx]
+ ;
+ ( Context.is_unsat ctx
+ || Formula.equal Formula.ff
+ (Formula.map_terms ~f:(Context.normalize ctx) asserts) )
+ |>
+ [%Trace.retn fun {pf} -> pf "%b"]
+
+exception Unsound
+exception Incomplete
+
+let expect_unsat = ref false
+
+let check_sat () =
+ let unsat = Iter.for_all ~f:check_unsat (x_context (top ())) in
+ if (not unsat) && !expect_unsat then raise Incomplete
+ else if unsat && not !expect_unsat then raise Unsound
+
+let process_stmt (stmt : Smt.Ast.statement) =
+ match stmt.stmt with
+ | Stmt_set_logic _ -> ()
+ | Stmt_set_info (":status", "unsat") -> expect_unsat := true
+ | Stmt_set_info (":status", _) -> expect_unsat := false
+ | Stmt_set_info _ | Stmt_set_option _ | Stmt_decl_sort _ -> ()
+ | Stmt_decl {fun_name; fun_args= []} -> decl_var fun_name
+ | Stmt_decl _ -> todo "%a" Smt.Ast.pp_stmt stmt ()
+ | Stmt_fun_def {fr_decl= {fun_name; fun_args= []}; fr_body} ->
+ assert_term (Eq (Const fun_name, fr_body))
+ | Stmt_fun_def _ | Stmt_fun_rec _ | Stmt_funs_rec _ ->
+ fail "function definition: %a" Smt.Ast.pp_stmt stmt ()
+ | Stmt_data _ -> fail "datatype definition" ()
+ | Stmt_assert term -> assert_term term
+ | Stmt_get_assertions | Stmt_get_assignment | Stmt_get_info _
+ |Stmt_get_model | Stmt_get_option _ | Stmt_get_proof
+ |Stmt_get_unsat_assumptions | Stmt_get_unsat_core | Stmt_get_value _ ->
+ ()
+ | Stmt_check_sat -> check_sat ()
+ | Stmt_check_sat_assuming _ -> fail "check-sat-assuming" ()
+ | Stmt_pop n ->
+ for _ = 1 to n do
+ pop ()
+ done
+ | Stmt_push n ->
+ for _ = 1 to n do
+ push ()
+ done
+ | Stmt_reset | Stmt_reset_assertions -> reset ()
+ | Stmt_exit -> ()
+
+let process filename =
+ List.iter ~f:process_stmt (Smt.parse_file_exn filename)
diff --git a/sledge/bin/smtlib.mli b/sledge/bin/smtlib.mli
new file mode 100644
index 000000000..f80ee12ee
--- /dev/null
+++ b/sledge/bin/smtlib.mli
@@ -0,0 +1,13 @@
+(*
+ * Copyright (c) Facebook, Inc. and its affiliates.
+ *
+ * This source code is licensed under the MIT license found in the
+ * LICENSE file in the root directory of this source tree.
+ *)
+
+(** Process SMT-LIB benchmarks using SLEdge's first-order theory solver. *)
+
+exception Unsound
+exception Incomplete
+
+val process : string -> unit
diff --git a/sledge/dune b/sledge/dune
index 3ff4ba061..ea1e10e0f 100644
--- a/sledge/dune
+++ b/sledge/dune
@@ -109,7 +109,8 @@
(package sledge)
(libraries apron apron.boxMPQ ctypes ctypes.foreign dune-build-info llvm
llvm.irreader llvm.analysis llvm.scalar_opts llvm.target llvm.ipo
- llvm.linker shexp.process yojson trace nonstdlib sledge model)
+ llvm.linker shexp.process yojson trace nonstdlib sledge model
+ smtlib-utils)
(flags
(:standard -w -58 -open NS -open Sledge -open Model))
(preprocess
diff --git a/sledge/sledge-help.txt b/sledge/sledge-help.txt
index c4986bc85..7f1cc7511 100644
--- a/sledge/sledge-help.txt
+++ b/sledge/sledge-help.txt
@@ -15,6 +15,7 @@ The [-trace ] argument of each subcommand enables debug tracing according
. translate translate LLVM bitcode to LLAIR
analyze analyze LLAIR code
disassemble print LLAIR code in textual form
+ smt process SMT-LIB benchmarks
version print version information
help explain a given subcommand (perhaps recursively)
@@ -224,6 +225,23 @@ The file must be LLAIR code, as produced by `sledge llvm translate`.
(alias: -?)
+====== sledge smt ======
+
+process SMT-LIB benchmarks
+
+ sledge smt
+
+The file is interpreted as an SMT-LIB 2 benchmark.
+
+=== flags ===
+
+ [-colors] enable printing in colors
+ [-margin ] wrap debug tracing at columns
+ [-trace ] enable debug tracing
+ [-help] print this help text and exit
+ (alias: -?)
+
+
====== sledge version ======
print version information
diff --git a/sledge/sledge.opam b/sledge/sledge.opam
index 465619115..77fece1be 100644
--- a/sledge/sledge.opam
+++ b/sledge/sledge.opam
@@ -23,6 +23,7 @@ depends: [
"ppx_compare"
"ppx_hash"
"shexp"
+ "smtlib-utils"
"yojson"
"zarith"
]