[sledge] Rearrange into CLI binary and LLVM-independent library

Summary:
Move files, adjust build system, etc.

This also separates out the ppx_trace conditional compilation debug
tracing machinery into an independent package and library.

Reviewed By: jvillard

Differential Revision: D20322876

fbshipit-source-id: a50522462
master
Josh Berdine 5 years ago committed by Facebook Github Bot
parent d5158f0787
commit b6ddd8fe8e

10
sledge/.gitignore vendored

@ -1,15 +1,11 @@
.llvm_build
.llvm_install
.merlin
/bin/dune
/lib/dune
/lib/import/dune
/llvm/
/model/dune
/src/config/dune
/src/domain/dune
/src/dune
/src/import/dune
/src/llair/dune
/src/symbheap/dune
/src/trace/dune
/test/*/*.bc
/test/*/*.bc.err
/test/*/*.bc.out

@ -6,9 +6,9 @@
.PHONY: default
default: exes
EXES = src/sledge
EXES = bin/sledge
INSTALLS = sledge
FMTS = @_build/dbg/src/fmt
FMTS = @_build/dbg/lib/fmt @_build/dbg/bin/fmt
DBG_TARGETS = $(patsubst %,_build/dbg/%.exe,$(EXES)) $(patsubst %,_build/dbg/%.install,$(INSTALLS)) _build/dbg/sledge-help.txt
@ -23,7 +23,7 @@ dune_install_dbg_opt = $(subst dbg,dbg-opt,$(dune_install_dbg))
dune_build_opt = $(subst dbg,opt,$(dune_build_dbg))
dune_install_opt = $(subst dbg,opt,$(dune_install_dbg))
DUNEINS = $(shell find src model -name dune.in)
DUNEINS = $(shell find lib bin model -name dune.in)
DUNES = $(patsubst %.in,%,$(DUNEINS))
.PHONY: dunes

@ -6,7 +6,7 @@
* LICENSE file in the root directory of this source tree.
*)
let deps = ["import"; "trace"; "llair_"; "symbheap"; "config"; "domain"]
let deps = ["import"; "libsledge"; "model"]
;;
Jbuild_plugin.V1.send
@ -15,8 +15,8 @@ Jbuild_plugin.V1.send
(executable
(public_name sledge)
(package sledge)
%s
(libraries dune-build-info shexp.process %s))
(libraries dune-build-info llvm llvm.irreader llvm.analysis llvm.scalar_opts llvm.target llvm.ipo llvm.linker shexp.process yojson %s)
%s)
|}
(libraries ("trace" :: deps))
(flags `exe deps)
(libraries deps)

@ -13,10 +13,10 @@ open Command.Let_syntax
type 'a param = 'a Command.Param.t
module Sh_executor = Control.Make (Domain.Relation.Make (Sh_domain))
module Unit_executor = Control.Make (Domain.Unit)
module Used_globals_executor = Control.Make (Domain.Used_globals)
module Itv_executor = Control.Make (Domain.Itv)
module Sh_executor = Control.Make (Domain_relation.Make (Domain_sh))
module Unit_executor = Control.Make (Domain_unit)
module Used_globals_executor = Control.Make (Domain_used_globals)
module Itv_executor = Control.Make (Domain_itv)
(* reverse application in the Command.Param applicative *)
let ( |*> ) : 'a param -> ('a -> 'b) param -> 'b param =
@ -70,7 +70,7 @@ let unmarshal file () =
~f:(fun ic -> (Marshal.from_channel ic : Llair.t))
file
let used_globals pgm preanalyze : Used_globals.r =
let used_globals pgm preanalyze : Domain_used_globals.r =
if preanalyze then
let summary_table =
Used_globals_executor.compute_summaries
@ -122,7 +122,7 @@ let analyze =
let globals = used_globals pgm preanalyze_globals in
let entry_points = Config.find_list "entry-points" in
let skip_throw = not exceptions in
Sh_domain.simplify_states := not no_simplify_states ;
Domain_sh.simplify_states := not no_simplify_states ;
exec {bound; skip_throw; function_summaries; entry_points; globals} pgm
let analyze_cmd =

@ -1,8 +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.
(ignored_subdirs (llvm test))
(rule
(targets sledge-help.txt)
(deps src/sledge.ml src/sledge_buck.ml tools/gen_help.sh src/sledge.exe)
(deps bin/sledge.ml bin/sledge_buck.ml tools/gen_help.sh bin/sledge.exe)
(action
(with-stdout-to sledge-help.txt
(run tools/gen_help.sh)))

@ -14,9 +14,9 @@ type exec_opts =
; skip_throw: bool
; function_summaries: bool
; entry_points: string list
; globals: Used_globals.r }
; globals: Domain_used_globals.r }
module Make (Dom : Domain_sig.Dom) = struct
module Make (Dom : Domain_intf.Dom) = struct
module Stack : sig
type t
type as_inlined_location = t [@@deriving compare, sexp_of]
@ -313,7 +313,9 @@ module Make (Dom : Domain_sig.Dom) = struct
let summarize post_state =
if not opts.function_summaries then post_state
else
let globals = Used_globals.by_function opts.globals name.reg in
let globals =
Domain_used_globals.by_function opts.globals name.reg
in
let function_summary, post_state =
Dom.create_summary ~locals post_state
~formals:(Set.union (Reg.Set.of_list formals) globals)
@ -435,7 +437,7 @@ module Make (Dom : Domain_sig.Dom) = struct
exec_skip_func stk state block areturn return
| None ->
exec_call opts stk state block {call with callee}
(Used_globals.by_function opts.globals
(Domain_used_globals.by_function opts.globals
callee.name.reg) )
|> Work.seq x ) )
| Return {exp} -> exec_return ~opts stk state block exp
@ -470,7 +472,8 @@ module Make (Dom : Domain_sig.Dom) = struct
(Work.init
(fst
(Dom.call ~summaries:opts.function_summaries
~globals:(Used_globals.by_function opts.globals reg)
~globals:
(Domain_used_globals.by_function opts.globals reg)
~actuals:[] ~areturn:None ~formals:[] ~freturn ~locals
(Dom.init pgm.globals)))
entry)

@ -12,9 +12,9 @@ type exec_opts =
; skip_throw: bool (** Treat throw as unreachable *)
; function_summaries: bool (** Use function summarisation *)
; entry_points: string list
; globals: Used_globals.r }
; globals: Domain_used_globals.r }
module Make (Dom : Domain_sig.Dom) : sig
module Make (Dom : Domain_intf.Dom) : sig
val exec_pgm : exec_opts -> Llair.t -> unit
val compute_summaries : exec_opts -> Llair.t -> Dom.summary list Reg.Map.t
end

@ -7,4 +7,4 @@
(** Interval abstract domain *)
include Domain_sig.Dom
include Domain_intf.Dom

@ -9,7 +9,7 @@
triples over a base state domain *)
module type State_domain_sig = sig
include Domain_sig.Dom
include Domain_intf.Dom
val create_summary :
locals:Reg.Set.t

@ -9,7 +9,7 @@
triples over a base domain *)
module type State_domain_sig = sig
include Domain_sig.Dom
include Domain_intf.Dom
val create_summary :
locals:Reg.Set.t
@ -19,4 +19,4 @@ module type State_domain_sig = sig
-> summary * t
end
module Make (State_domain : State_domain_sig) : Domain_sig.Dom
module Make (State_domain : State_domain_sig) : Domain_intf.Dom

@ -7,7 +7,7 @@
(** Abstract domain *)
include Domain_sig.Dom
include Domain_intf.Dom
(* formals should include all the parameters of the summary. That is both
formals and globals. *)

@ -7,4 +7,4 @@
(** "Unit" abstract domain *)
include Domain_sig.Dom
include Domain_intf.Dom

@ -7,7 +7,7 @@
(** Used-globals abstract domain *)
include Domain_sig.Dom with type summary = Reg.Set.t
include Domain_intf.Dom with type summary = Reg.Set.t
type r =
| Per_function of Reg.Set.t Reg.Map.t

@ -13,10 +13,9 @@ Jbuild_plugin.V1.send
@@ Format.sprintf
{|
(library
(name trace)
(public_name llair.trace)
%s
(libraries %s))
(name libsledge)
(libraries apron apron.boxMPQ ctypes ctypes.foreign %s)
%s)
|}
(libraries ("trace" :: deps))
(flags `lib deps)
(libraries deps)

@ -7,8 +7,8 @@
let%test_module _ =
( module struct
(* let () = Trace.init ~margin:68 ~config:all () *)
let () = Trace.init ~margin:68 ~config:none ()
(* let () = Trace.init ~margin:68 ~config:Trace.all () *)
let () = Trace.init ~margin:68 ()
open Exp

@ -14,9 +14,9 @@ Jbuild_plugin.V1.send
{|
(library
(name import)
(public_name llair.import)
%s
(libraries core core_kernel.fheap zarith %s))
(public_name sledge.import)
(libraries core core_kernel.fheap zarith %s)
%s)
|}
(libraries ("trace" :: deps))
(flags `lib deps)
(libraries deps)

@ -48,10 +48,16 @@ let ( <$ ) f x = f x ; x
(** Pretty-printing *)
type 'a pp = Formatter.t -> 'a -> unit
type ('a, 'b) fmt = ('a, Formatter.t, unit, 'b) format4
type ('a, 'b) fmt = ('a, 'b) Trace.fmt
(** Failures *)
let fail = Trace.fail
exception Unimplemented of string
let todo fmt = Trace.raisef (fun msg -> Unimplemented msg) fmt
let warn fmt =
let fs = Format.std_formatter in
Format.pp_open_box fs 2 ;
@ -62,27 +68,7 @@ let warn fmt =
Format.pp_force_newline fs () )
fs fmt
let raisef ?margin exn fmt =
let bt = Caml.Printexc.get_raw_backtrace () in
let fs = Format.str_formatter in
( match margin with
| Some m ->
Format.pp_set_margin fs m ;
Format.pp_set_max_indent fs (m - 1)
| None -> () ) ;
Format.pp_open_box fs 2 ;
Format.kfprintf
(fun fs () ->
Format.pp_close_box fs () ;
let msg = Format.flush_str_formatter () in
let exn = exn msg in
Caml.Printexc.raise_with_backtrace exn bt )
fs fmt
exception Unimplemented of string
let todo fmt = raisef (fun msg -> Unimplemented msg) fmt
let fail fmt = raisef (fun msg -> Failure msg) fmt
(** Assertions *)
let assertf cnd fmt =
if not cnd then fail fmt

@ -69,24 +69,25 @@ val ( <$ ) : ('a -> unit) -> 'a -> 'a
type 'a pp = Formatter.t -> 'a -> unit
(** Format strings. *)
type ('a, 'b) fmt = ('a, Formatter.t, unit, 'b) format4
type ('a, 'b) fmt = ('a, 'b) Trace.fmt
(** Failures *)
exception Unimplemented of string
val raisef : ?margin:int -> (string -> exn) -> ('a, unit -> _) fmt -> 'a
(** Take a function from a string message to an exception, and a format
string with the additional arguments it specifies, and then call the
function on the formatted string and raise the returned exception. *)
val warn : ('a, unit -> unit) fmt -> 'a
(** Issue a warning for a survivable problem. *)
val fail : ('a, unit -> _) fmt -> 'a
(** Emit a message at the current indentation level, and raise a [Failure]
exception indicating a fatal error. *)
val todo : ('a, unit -> _) fmt -> 'a
(** Raise an [Unimplemented] exception indicating that an input is valid but
not handled by the current implementation. *)
val warn : ('a, unit -> unit) fmt -> 'a
(** Issue a warning for a survivable problem. *)
(** Assertions *)
val assertf : bool -> ('a, unit -> unit) fmt -> 'a
(** Raise an [Failure] exception if the bool argument is false, indicating
that the expected condition was not satisfied. *)

@ -136,8 +136,8 @@ let fresh_var name vs zs ~wrt =
let v = Term.var v in
(v, vs, zs, wrt)
let excise k = [%Trace.infok k]
let trace k = [%Trace.infok k]
let excise (k : Trace.pf -> _) = [%Trace.infok k]
let trace (k : Trace.pf -> _) = [%Trace.infok k]
let excise_exists goal =
trace (fun {pf} -> pf "@[<2>excise_exists@ %a@]" pp goal) ;

@ -7,8 +7,8 @@
let%test_module _ =
( module struct
(* let () = Trace.init ~margin:68 ~config:all () *)
let () = Trace.init ~margin:68 ~config:none ()
(* let () = Trace.init ~margin:68 ~config:Trace.all () *)
let () = Trace.init ~margin:68 ()
open Term

@ -1,21 +0,0 @@
opam-version: "1.2"
maintainer: "Josh Berdine <jjb@fb.com>"
authors: "Josh Berdine <jjb@fb.com>"
homepage: "https://github.com/facebook/infer/tree/master/sledge/src/llair"
bug-reports: "https://github.com/facebook/infer/issues"
build: [
[make "dunes"]
["dune" "build" "-p" name "-j" jobs]
]
depends: [
"base" {>= "v0.12.0"}
"cmdliner"
"core_kernel" {>= "v0.11.0"}
"ctypes"
"ctypes-foreign"
"dune" {build}
"llvm" {build & = "7.0.0"}
"ppx_compare" {>= "v0.11.0"}
"ppx_hash" {>= "v0.11.0"}
"zarith"
]

@ -22,7 +22,6 @@ Jbuild_plugin.V1.send
(deps lib_fuzzer_main.c Makefile)
(action (run make ROOT=../../.. lib_fuzzer_main.bc)))
(rule
(targets model.ml)
(deps cxxabi.bc lib_fuzzer_main.bc)
@ -30,9 +29,9 @@ Jbuild_plugin.V1.send
(library
(name model)
(public_name llair.model)
%s
(libraries %s))
(public_name sledge.model)
(libraries %s)
%s)
|}
(flags `lib deps)
(libraries deps)
(flags `lib deps)

@ -0,0 +1,18 @@
opam-version: "2.0"
maintainer: "Josh Berdine <jjb@fb.com>"
authors: "Josh Berdine <jjb@fb.com>"
homepage: "https://github.com/facebook/infer/tree/master/sledge/ppx_trace"
bug-reports: "https://github.com/facebook/infer/issues/new?template=sledge_issue_template.md"
dev-repo: "git://github.com/facebook/infer.git"
license: "MIT"
build: [
["dune" "build" "-p" name "-j" jobs]
]
depends: [
"ocaml"
"base" {>= "v0.12.0"}
"dune" {>= "1.11.3" build}
"ppxlib"
]
synopsis: "Conditionally compiled debug tracing"
description: "Conditionally compiled debug tracing"

@ -45,8 +45,7 @@ module Ast_mapper = Selected_ast.Ast.Ast_mapper
let debug = ref false
;;
Driver.add_arg "--debug" (Caml.Arg.Set debug)
~doc:"Enable debug tracing output"
Driver.add_arg "--debug" (Arg.Set debug) ~doc:"Enable debug tracing output"
let rec get_fun_name pat =
match pat.ppat_desc with

@ -0,0 +1,9 @@
; 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.
(library
(name trace)
(public_name ppx_trace.trace)
(libraries base))

@ -5,9 +5,15 @@
* LICENSE file in the root directory of this source tree.
*)
module Char = Base.Char
module List = Base.List
module Map = Base.Map
module Option = Base.Option
module String = Base.String
(** Debug trace logging *)
type 'a printf = ('a, Formatter.t, unit) format -> 'a
type 'a printf = ('a, Format.formatter, unit) format -> 'a
type pf = {pf: 'a. 'a printf}
let fs = Format.err_formatter
@ -98,7 +104,7 @@ let pp_styled style fmt fs =
Format.pp_close_box fs () )
fs fmt )
let init ?(colors = false) ?(margin = 240) ~config:c () =
let init ?(colors = false) ?(margin = 240) ?config:(c = none) () =
Format.set_margin margin ;
Format.set_max_indent (margin - 1) ;
Format.pp_set_margin fs margin ;
@ -119,7 +125,7 @@ let unwrap s =
| None -> s
let enabled mod_name fun_name =
let {trace_all; trace_mods_funs} = !config in
let {trace_all; trace_mods_funs; _} = !config in
match Map.find trace_mods_funs (unwrap mod_name) with
| Some {trace_mod; trace_funs} -> (
match Map.find trace_funs fun_name with
@ -168,6 +174,25 @@ let retn mod_name fun_name k result =
k {pf= (fun fmt -> decf mod_name fun_name fmt)} result ;
result
type ('a, 'b) fmt = ('a, Base.Formatter.t, unit, 'b) format4
let raisef ?margin exn fmt =
let bt = Caml.Printexc.get_raw_backtrace () in
let fs = Format.str_formatter in
( match margin with
| Some m ->
Format.pp_set_margin fs m ;
Format.pp_set_max_indent fs (m - 1)
| None -> () ) ;
Format.pp_open_box fs 2 ;
Format.kfprintf
(fun fs () ->
Format.pp_close_box fs () ;
let msg = Format.flush_str_formatter () in
let exn = exn msg in
Caml.Printexc.raise_with_backtrace exn bt )
fs fmt
let fail fmt =
let margin = Format.pp_get_margin fs () in
raisef ~margin
@ -175,6 +200,3 @@ let fail fmt =
Format.fprintf fs "@\n@[<2>| %s@]@." msg ;
Failure msg )
fmt
let%test_module _ =
(module struct let () = init ~margin:70 ~config:!config () end)

@ -11,10 +11,10 @@
type trace_mod_funs =
{ trace_mod: bool option
(** Enable/disable tracing of all functions in module *)
; trace_funs: bool Map.M(String).t
; trace_funs: bool Base.Map.M(Base.String).t
(** Enable/disable tracing of individual functions *) }
type trace_mods_funs = trace_mod_funs Map.M(String).t
type trace_mods_funs = trace_mod_funs Base.Map.M(Base.String).t
type config =
{ trace_all: bool (** Enable all tracing *)
@ -26,10 +26,10 @@ val none : config
val all : config
val parse : string -> (config, exn) result
val init : ?colors:bool -> ?margin:int -> config:config -> unit -> unit
val init : ?colors:bool -> ?margin:int -> ?config:config -> unit -> unit
(** Initialize the configuration of debug tracing. *)
type 'a printf = ('a, Formatter.t, unit) format -> 'a
type 'a printf = ('a, Format.formatter, unit) format -> 'a
type pf = {pf: 'a. 'a printf}
val pp_styled :
@ -42,10 +42,10 @@ val pp_styled :
val printf : string -> string -> 'a printf
(** Like [Format.printf], if enabled, otherwise like [Format.iprintf]. *)
val fprintf : string -> string -> Formatter.t -> 'a printf
val fprintf : string -> string -> Format.formatter -> 'a printf
(** Like [Format.fprintf], if enabled, otherwise like [Format.ifprintf]. *)
val kprintf : string -> string -> (Formatter.t -> unit) -> 'a printf
val kprintf : string -> string -> (Format.formatter -> unit) -> 'a printf
(** Like [Format.kprintf], if enabled, otherwise like [Format.ifprintf]. *)
val info : string -> string -> 'a printf
@ -63,6 +63,14 @@ val retn : string -> string -> (pf -> 'a -> unit) -> 'a -> 'a
val flush : unit -> unit
(** Flush the internal buffers. *)
(** Format strings. *)
type ('a, 'b) fmt = ('a, Format.formatter, unit, 'b) format4
val raisef : ?margin:int -> (string -> exn) -> ('a, unit -> _) fmt -> 'a
(** Take a function from a string message to an exception, and a format
string with the additional arguments it specifies, and then call the
function on the formatted string and raise the returned exception. *)
val fail : ('a, unit -> _) fmt -> 'a
(** Emit a message at the current indentation level, and raise a [Failure]
exception indicating a fatal error. *)

@ -1,22 +0,0 @@
(* -*- tuareg -*- *)
(*
* 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.
*)
let deps = ["import"; "trace"]
;;
Jbuild_plugin.V1.send
@@ Format.sprintf
{|
(library
(name config)
(public_name llair.config)
%s
(libraries yojson %s))
|}
(flags `lib deps)
(libraries deps)

@ -1,21 +0,0 @@
(* -*- tuareg -*- *)
(*
* 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.
*)
let deps = ["import"; "trace"; "llair_"]
;;
Jbuild_plugin.V1.send
@@ Format.sprintf
{|
(library
(name domain)
%s
(libraries apron apron.boxMPQ %s))
|}
(flags `lib deps)
(libraries deps)

@ -1,22 +0,0 @@
(* -*- tuareg -*- *)
(*
* 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.
*)
let deps = ["model"; "import"; "trace"; "config"]
;;
Jbuild_plugin.V1.send
@@ Format.sprintf
{|
(library
(name llair_)
(public_name llair)
%s
(libraries ctypes ctypes.foreign llvm llvm.irreader llvm.analysis llvm.scalar_opts llvm.target llvm.ipo llvm.linker %s))
|}
(flags `lib deps)
(libraries deps)

@ -1,20 +0,0 @@
(* -*- tuareg -*- *)
(*
* 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.
*)
let deps = ["import"; "trace"; "llair_"; "domain"]
;;
Jbuild_plugin.V1.send
@@ Format.sprintf {|
(library
(name symbheap)
%s
(libraries %s))
|}
(flags `lib deps)
(libraries deps)
Loading…
Cancel
Save