[sledge] Functorize worklist, separate out domain-specific logic

Summary: Add support for future development of new abstract domains by eliminating hard-wired dependencies from the worklist into the symbolic heap domain.  Also includes an implementation of a trivial unit domain and a CLI flag to enable its use, for debugging purposes.

Reviewed By: jberdine

Differential Revision: D17281681

fbshipit-source-id: 5858fd420

sledge/sledge-help.txt

@@ -55,6 +55,8 @@ Analyze code in a buck target. This is a convenience wrapper for the sequence `s
                           output if <file> is `-`
   [-skip-throw]           do not explore past throwing an exception
   [-trace <spec>]         enable debug tracing
+  [-unit-domain]          use unit domain (experimental, debugging purposes
+                          only)
   [-help]                 print this help text and exit
                           (alias: -?)
 
@@ -132,6 +134,8 @@ Analyze code in one or more LLVM bitcode files. This is a convenience wrapper fo
   [-margin <cols>]        wrap debug tracing at <cols> columns
   [-skip-throw]           do not explore past throwing an exception
   [-trace <spec>]         enable debug tracing
+  [-unit-domain]          use unit domain (experimental, debugging purposes
+                          only)
   [-help]                 print this help text and exit
                           (alias: -?)
 
@@ -171,6 +175,7 @@ The <input> file must be binary LLAIR, such as produced by `sledge translate`.
   [-margin <cols>]       wrap debug tracing at <cols> columns
   [-skip-throw]          do not explore past throwing an exception
   [-trace <spec>]        enable debug tracing
+  [-unit-domain]         use unit domain (experimental, debugging purposes only)
   [-help]                print this help text and exit
                          (alias: -?)
 

sledge/src/control.ml

@@ -11,30 +11,31 @@
 
 type exec_opts = {bound: int; skip_throw: bool; function_summaries: bool}
 
-module Stack : sig
+module Make (Dom : Domain_sig.Dom) = struct
+  module Stack : sig
     type t
     type as_inlined_location = t [@@deriving compare, sexp_of]
 
     val empty : t
 
     val push_call :
-    Llair.func Llair.call -> bound:int -> Domain.from_call -> t -> t option
+      Llair.func Llair.call -> bound:int -> Dom.from_call -> t -> t option
 
-  val pop_return : t -> (Domain.from_call * Llair.jump * t) option
+    val pop_return : t -> (Dom.from_call * Llair.jump * t) option
 
     val pop_throw :
          t
       -> init:'a
-    -> unwind:(Var.t list -> Var.Set.t -> Domain.from_call -> 'a -> 'a)
-    -> (Domain.from_call * Llair.jump * t * 'a) option
-end = struct
+      -> unwind:(Var.t list -> Var.Set.t -> Dom.from_call -> 'a -> 'a)
+      -> (Dom.from_call * Llair.jump * t * 'a) option
+  end = struct
     type t =
       | Return of
           { recursive: bool  (** return from a possibly-recursive call *)
           ; dst: Llair.Jump.t
           ; params: Var.t list
           ; locals: Var.Set.t
-        ; from_call: Domain.from_call
+          ; from_call: Dom.from_call
           ; stk: t }
       | Throw of Llair.Jump.t * t
       | Empty
@@ -43,10 +44,10 @@ end = struct
     type as_inlined_location = t [@@deriving sexp_of]
 
     (* Treat a stack as a code location in a hypothetical expansion of the
-     program where all non-recursive functions have been completely inlined.
-     In particular, this means to compare stacks as if all Return frames for
-     recursive calls had been removed. Additionally, the from_call info in
-     Return frames is ignored. *)
+       program where all non-recursive functions have been completely
+       inlined. In particular, this means to compare stacks as if all Return
+       frames for recursive calls had been removed. Additionally, the
+       from_call info in Return frames is ignored. *)
     let rec compare_as_inlined_location x y =
       if x == y then 0
       else
@@ -130,12 +131,12 @@ end = struct
         | Throw _ as stk -> violates invariant stk
       in
       pop_throw_ init stk
-end
+  end
 
-module Work : sig
+  module Work : sig
     type t
 
-  val init : Domain.t -> Llair.block -> int -> t
+    val init : Dom.t -> Llair.block -> int -> t
 
     type x
 
@@ -146,12 +147,12 @@ module Work : sig
          ?prev:Llair.block
       -> retreating:bool
       -> Stack.t
-    -> Domain.t
+      -> Dom.t
       -> Llair.block
       -> x
 
-  val run : f:(Stack.t -> Domain.t -> Llair.block -> x) -> t -> unit
-end = struct
+    val run : f:(Stack.t -> Dom.t -> Llair.block -> x) -> t -> unit
+  end = struct
     module Edge = struct
       module T = struct
         type t =
@@ -186,11 +187,13 @@ end = struct
 
     type priority = int * Edge.t [@@deriving compare]
     type priority_queue = priority Fheap.t
-  type waiting_states = (Domain.t * Depths.t) list Map.M(Llair.Block).t
+    type waiting_states = (Dom.t * Depths.t) list Map.M(Llair.Block).t
     type t = priority_queue * waiting_states * int
     type x = Depths.t -> t -> t
 
-  let empty_waiting_states : waiting_states = Map.empty (module Llair.Block)
+    let empty_waiting_states : waiting_states =
+      Map.empty (module Llair.Block)
+
     let pp_priority fs (n, e) = Format.fprintf fs "%i: %a" n Edge.pp e
 
     let pp fs pq =
@@ -225,31 +228,31 @@ end = struct
       | Some ((_, ({Edge.dst; stk} as edge)), pq) -> (
         match Map.find_and_remove ws dst with
         | Some (state :: states, ws) ->
-          let join (qa, da) (q, d) = (Domain.join q qa, Depths.join d da) in
+            let join (qa, da) (q, d) = (Dom.join q qa, Depths.join d da) in
             let qs, depths = List.fold ~f:join ~init:state states in
             run ~f (f stk qs dst depths (pq, ws, bnd))
         | _ ->
             [%Trace.info "done: %a" Edge.pp edge] ;
             run ~f (pq, ws, bnd) )
       | None -> [%Trace.info "queue empty"] ; ()
-end
+  end
 
-let exec_jump stk state block Llair.{dst; retreating} =
+  let exec_jump stk state block Llair.{dst; retreating} =
     Work.add ~prev:block ~retreating stk state dst
 
-let summary_table = Hashtbl.create (module Var)
+  let summary_table = Hashtbl.create (module Var)
 
-let exec_call opts stk state block call globals =
+  let exec_call opts stk state block call globals =
     let Llair.{callee; args; areturn; return; recursive} = call in
     let Llair.{name; params; freturn; locals; entry} = callee in
     [%Trace.call fun {pf} ->
       pf "%a from %a" Var.pp name.var Var.pp return.dst.parent.name.var]
     ;
     let dnf_states =
-    if opts.function_summaries then Domain.dnf state else [state]
+      if opts.function_summaries then Dom.dnf state else [state]
     in
     let domain_call =
-    Domain.call args areturn params (Set.add_option freturn locals) globals
+      Dom.call args areturn params (Set.add_option freturn locals) globals
     in
     List.fold ~init:Work.skip dnf_states ~f:(fun acc state ->
         match
@@ -258,11 +261,10 @@ let exec_call opts stk state block call globals =
             let maybe_summary_post =
               let state = fst (domain_call ~summaries:false state) in
               Hashtbl.find summary_table name.var
-            >>= List.find_map ~f:(Domain.apply_summary state)
+              >>= List.find_map ~f:(Dom.apply_summary state)
             in
             [%Trace.info
-            "Maybe summary post: %a"
-              (Option.pp "%a" Domain.pp)
+              "Maybe summary post: %a" (Option.pp "%a" Dom.pp)
                 maybe_summary_post] ;
             maybe_summary_post
         with
@@ -271,7 +273,9 @@ let exec_call opts stk state block call globals =
               domain_call ~summaries:opts.function_summaries state
             in
             Work.seq acc
-            ( match Stack.push_call call ~bound:opts.bound from_call stk with
+              ( match
+                  Stack.push_call call ~bound:opts.bound from_call stk
+                with
               | Some stk ->
                   Work.add stk ~prev:block ~retreating:recursive state entry
               | None -> Work.skip )
@@ -279,15 +283,15 @@ let exec_call opts stk state block call globals =
     |>
     [%Trace.retn fun {pf} _ -> pf ""]
 
-let pp_st () =
+  let pp_st () =
     [%Trace.printf
       "@[<v>%t@]" (fun fs ->
           Hashtbl.iteri summary_table ~f:(fun ~key ~data ->
               Format.fprintf fs "@[<v>%a:@ @[%a@]@]@ " Var.pp key
-              (List.pp "@," State_domain.pp_function_summary)
+                (List.pp "@," Dom.pp_summary)
                 data ) )]
 
-let exec_return ~opts stk pre_state (block : Llair.block) exp globals =
+  let exec_return ~opts stk pre_state (block : Llair.block) exp globals =
     let Llair.{name; params; freturn; locals} = block.parent in
     [%Trace.call fun {pf} -> pf "from %a" Var.pp name.var]
     ;
@@ -296,11 +300,11 @@ let exec_return ~opts stk pre_state (block : Llair.block) exp globals =
         let exit_state =
           match (freturn, exp) with
           | Some freturn, Some return_val ->
-            Domain.exec_move pre_state freturn return_val
+              Dom.exec_move pre_state freturn return_val
           | None, None -> pre_state
           | _ -> violates Llair.Func.invariant block.parent
         in
-      let post_state = Domain.post locals from_call exit_state in
+        let post_state = Dom.post locals from_call exit_state in
         let post_state =
           if opts.function_summaries then (
             let globals =
@@ -308,7 +312,7 @@ let exec_return ~opts stk pre_state (block : Llair.block) exp globals =
                 (Vector.map globals ~f:(fun (g : Global.t) -> g.var))
             in
             let function_summary, post_state =
-            Domain.create_summary ~locals post_state
+              Dom.create_summary ~locals post_state
                 ~formals:(Set.union (Var.Set.of_list params) globals)
             in
             Hashtbl.add_multi summary_table ~key:name.var
@@ -317,59 +321,59 @@ let exec_return ~opts stk pre_state (block : Llair.block) exp globals =
             post_state )
           else post_state
         in
-      let retn_state = Domain.retn params freturn from_call post_state in
+        let retn_state = Dom.retn params freturn from_call post_state in
         exec_jump stk retn_state block retn_site
     | None -> Work.skip )
     |>
     [%Trace.retn fun {pf} _ -> pf ""]
 
-let exec_throw stk pre_state (block : Llair.block) exc =
+  let exec_throw stk pre_state (block : Llair.block) exc =
     let func = block.parent in
     [%Trace.call fun {pf} -> pf "from %a" Var.pp func.name.var]
     ;
     let unwind params scope from_call state =
-    Domain.retn params (Some func.fthrow) from_call
-      (Domain.post scope from_call state)
+      Dom.retn params (Some func.fthrow) from_call
+        (Dom.post scope from_call state)
     in
     ( match Stack.pop_throw stk ~unwind ~init:pre_state with
     | Some (from_call, retn_site, stk, unwind_state) ->
         let fthrow = func.fthrow in
-      let exit_state = Domain.exec_move unwind_state fthrow exc in
-      let post_state = Domain.post func.locals from_call exit_state in
+        let exit_state = Dom.exec_move unwind_state fthrow exc in
+        let post_state = Dom.post func.locals from_call exit_state in
         let retn_state =
-        Domain.retn func.params func.freturn from_call post_state
+          Dom.retn func.params func.freturn from_call post_state
         in
         exec_jump stk retn_state block retn_site
     | None -> Work.skip )
     |>
     [%Trace.retn fun {pf} _ -> pf ""]
 
-let exec_skip_func :
+  let exec_skip_func :
          Stack.t
-    -> Domain.t
+      -> Dom.t
       -> Llair.block
       -> Var.t option
       -> Llair.jump
       -> Work.x =
    fun stk state block areturn return ->
     Report.unknown_call block.term ;
-  let state = Option.fold ~f:Domain.exec_kill ~init:state areturn in
+    let state = Option.fold ~f:Dom.exec_kill ~init:state areturn in
     exec_jump stk state block return
 
-let exec_term :
-    exec_opts -> Llair.t -> Stack.t -> Domain.t -> Llair.block -> Work.x =
+  let exec_term :
+      exec_opts -> Llair.t -> Stack.t -> Dom.t -> Llair.block -> Work.x =
    fun opts pgm stk state block ->
     [%Trace.info "exec %a" Llair.Term.pp block.term] ;
     match block.term with
     | Switch {key; tbl; els} ->
         Vector.fold tbl
           ~f:(fun x (case, jump) ->
-          match Domain.exec_assume state (Exp.eq key case) with
+            match Dom.exec_assume state (Exp.eq key case) with
             | Some state -> exec_jump stk state block jump |> Work.seq x
             | None -> x )
           ~init:
             ( match
-              Domain.exec_assume state
+                Dom.exec_assume state
                   (Vector.fold tbl ~init:(Exp.bool true)
                      ~f:(fun b (case, _) -> Exp.and_ (Exp.dq key case) b))
               with
@@ -378,7 +382,7 @@ let exec_term :
     | Iswitch {ptr; tbl} ->
         Vector.fold tbl ~init:Work.skip ~f:(fun x (jump : Llair.jump) ->
             match
-            Domain.exec_assume state
+              Dom.exec_assume state
                 (Exp.eq ptr
                    (Exp.label
                       ~parent:(Var.name jump.dst.parent.name.var)
@@ -391,19 +395,21 @@ let exec_term :
         let lookup name =
           Option.to_list (Llair.Func.find pgm.functions name)
         in
-      Domain.resolve_callee lookup callee state
+        Dom.resolve_callee lookup callee state
       with
       | [] -> exec_skip_func stk state block areturn return
       | callees ->
           List.fold callees ~init:Work.skip ~f:(fun x callee ->
               ( match
-                Domain.exec_intrinsic ~skip_throw:opts.skip_throw state
+                  Dom.exec_intrinsic ~skip_throw:opts.skip_throw state
                     areturn callee.name.var args
                 with
               | Some (Error ()) ->
-                Report.invalid_access_term (Domain.project state) block.term ;
+                  Report.invalid_access_term
+                    (Dom.report_fmt_thunk state)
+                    block.term ;
                   Work.skip
-            | Some (Ok state) when Domain.is_false state -> Work.skip
+              | Some (Ok state) when Dom.is_false state -> Work.skip
               | Some (Ok state) -> exec_jump stk state block return
               | None when Llair.Func.is_undefined callee ->
                   exec_skip_func stk state block areturn return
@@ -413,26 +419,27 @@ let exec_term :
               |> Work.seq x ) )
     | Return {exp} -> exec_return ~opts stk state block exp pgm.globals
     | Throw {exc} ->
-      if opts.skip_throw then Work.skip else exec_throw stk state block exc
+        if opts.skip_throw then Work.skip
+        else exec_throw stk state block exc
     | Unreachable -> Work.skip
 
-let exec_inst :
-    Domain.t -> Llair.inst -> (Domain.t, Domain.t * Llair.inst) result =
+  let exec_inst : Dom.t -> Llair.inst -> (Dom.t, Dom.t * Llair.inst) result
+      =
    fun state inst ->
-  Domain.exec_inst state inst
+    Dom.exec_inst state inst
     |> Result.map_error ~f:(fun () -> (state, inst))
 
-let exec_block :
-    exec_opts -> Llair.t -> Stack.t -> Domain.t -> Llair.block -> Work.x =
+  let exec_block :
+      exec_opts -> Llair.t -> Stack.t -> Dom.t -> Llair.block -> Work.x =
    fun opts pgm stk state block ->
     [%Trace.info "exec %a" Llair.Block.pp block] ;
     match Vector.fold_result ~f:exec_inst ~init:state block.cmnd with
     | Ok state -> exec_term opts pgm stk state block
     | Error (state, inst) ->
-      Report.invalid_access_inst (Domain.project state) inst ;
+        Report.invalid_access_inst (Dom.report_fmt_thunk state) inst ;
         Work.skip
 
-let harness : exec_opts -> Llair.t -> (int -> Work.t) option =
+  let harness : exec_opts -> Llair.t -> (int -> Work.t) option =
    fun opts pgm ->
     let entry_points = Config.find_list "entry-points" in
     List.find_map entry_points ~f:(fun name ->
@@ -442,12 +449,12 @@ let harness : exec_opts -> Llair.t -> (int -> Work.t) option =
         Some
           (Work.init
              (fst
-              (Domain.call ~summaries:opts.function_summaries [] None []
-                 locals pgm.globals (Domain.init pgm.globals)))
+                (Dom.call ~summaries:opts.function_summaries [] None []
+                   locals pgm.globals (Dom.init pgm.globals)))
              entry)
     | _ -> None
 
-let exec_pgm : exec_opts -> Llair.t -> unit =
+  let exec_pgm : exec_opts -> Llair.t -> unit =
    fun opts pgm ->
     [%Trace.call fun {pf} -> pf "@]@,@["]
     ;
@@ -456,3 +463,4 @@ let exec_pgm : exec_opts -> Llair.t -> unit =
     | None -> fail "no applicable harness" () )
     |>
     [%Trace.retn fun {pf} _ -> pf ""]
+end

sledge/src/control.mli

@@ -12,4 +12,6 @@ type exec_opts =
   ; skip_throw: bool  (** Treat throw as unreachable *)
   ; function_summaries: bool  (** Use function summarisation *) }
 
-val exec_pgm : exec_opts -> Llair.t -> unit
+module Make (Dom : Domain_sig.Dom) : sig
+  val exec_pgm : exec_opts -> Llair.t -> unit
+end

sledge/src/domain_sig.ml

@@ -0,0 +1,57 @@
+(*
+ * 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.
+ *)
+
+(** Abstract Domain *)
+module type Dom = sig
+  type t
+
+  val pp : t pp
+  val report_fmt_thunk : t -> Formatter.t -> unit
+  val init : Global.t vector -> t
+  val join : t -> t -> t
+  val is_false : t -> bool
+  val exec_assume : t -> Exp.t -> t option
+  val exec_kill : t -> Var.t -> t
+  val exec_move : t -> Var.t -> Exp.t -> t
+  val exec_inst : t -> Llair.inst -> (t, unit) result
+
+  val exec_intrinsic :
+       skip_throw:bool
+    -> t
+    -> Var.t option
+    -> Var.t
+    -> Exp.t list
+    -> (t, unit) result option
+
+  type from_call [@@deriving sexp_of]
+
+  val call :
+       summaries:bool
+    -> Exp.t list
+    -> Var.t option
+    -> Var.t list
+    -> Var.Set.t
+    -> Global.t vector
+    -> t
+    -> t * from_call
+
+  val post : Var.Set.t -> from_call -> t -> t
+  val retn : Var.t list -> Var.t option -> from_call -> t -> t
+  val dnf : t -> t list
+
+  val resolve_callee :
+    (Var.t -> Llair.func list) -> Exp.t -> t -> Llair.func list
+
+  type summary
+
+  val pp_summary : summary pp
+
+  val create_summary :
+    locals:Var.Set.t -> formals:Var.Set.t -> t -> summary * t
+
+  val apply_summary : t -> summary -> t option
+end

sledge/src/report.ml

@@ -22,18 +22,17 @@ let unknown_call call =
         | _ -> () )
       call Llair.Term.pp call]
 
-let invalid_access state pp access loc =
+let invalid_access fmt_thunk pp access loc =
   let rep fs =
     Format.fprintf fs "%a Invalid memory access@;<1 2>@[%a@]" Loc.pp
       (loc access) pp access
   in
   Format.printf "@\n@[<v 2>%t@]@." rep ;
-  [%Trace.printf
-    "@\n@[<v 2>%t@;<1 2>@[{ %a@ }@]@]@." rep State_domain.pp state] ;
+  [%Trace.printf "@\n@[<v 2>%t@;<1 2>@[{ %t@ }@]@]@." rep fmt_thunk] ;
   Stop.on_invalid_access ()
 
-let invalid_access_inst state inst =
-  invalid_access state Llair.Inst.pp inst Llair.Inst.loc
+let invalid_access_inst fmt_thunk inst =
+  invalid_access fmt_thunk Llair.Inst.pp inst Llair.Inst.loc
 
-let invalid_access_term state term =
-  invalid_access state Llair.Term.pp term Llair.Term.loc
+let invalid_access_term fmt_thunk term =
+  invalid_access fmt_thunk Llair.Term.pp term Llair.Term.loc

sledge/src/report.mli

@@ -8,5 +8,5 @@
 (** Issue reporting *)
 
 val unknown_call : Llair.term -> unit
-val invalid_access_inst : State_domain.t -> Llair.inst -> unit
-val invalid_access_term : State_domain.t -> Llair.term -> unit
+val invalid_access_inst : (Formatter.t -> unit) -> Llair.inst -> unit
+val invalid_access_term : (Formatter.t -> unit) -> Llair.term -> unit

sledge/src/sledge.ml

@@ -13,6 +13,9 @@ open Command.Let_syntax
 
 type 'a param = 'a Command.Param.t
 
+module Sh_executor = Control.Make (Sh_domain)
+module Unit_executor = Control.Make (Unit_domain)
+
 (* reverse application in the Command.Param applicative *)
 let ( |*> ) : 'a param -> ('a -> 'b) param -> 'b param =
  fun x f -> x |> Command.Param.apply f
@@ -75,9 +78,15 @@ let analyze =
   and function_summaries =
     flag "function-summaries" no_arg
       ~doc:"use function summaries (in development)"
+  and unit_domain =
+    flag "unit-domain" no_arg
+      ~doc:"use unit domain (experimental, debugging purposes only)"
+  in
+  let exec =
+    if unit_domain then Unit_executor.exec_pgm else Sh_executor.exec_pgm
   in
   fun program () ->
-    Control.exec_pgm {bound; skip_throw; function_summaries} (program ())
+    exec {bound; skip_throw; function_summaries} (program ())
 
 let analyze_cmd =
   let summary = "analyze LLAIR code" in

sledge/src/symbheap/sh_domain.ml

@@ -10,12 +10,12 @@
 type t = State_domain.t * State_domain.t
 
 let embed q = (q, q)
-let project (_, curr) = curr
 
 let pp fs (entry, current) =
   Format.fprintf fs "@[<v 1> entry: %a@;current: %a@]" State_domain.pp entry
     State_domain.pp current
 
+let report_fmt_thunk (_, curr) fs = State_domain.pp fs curr
 let init globals = embed (State_domain.init globals)
 
 let join (entry_a, current_a) (entry_b, current_b) =
@@ -95,6 +95,10 @@ let dnf (entry, current) =
 let resolve_callee f e (_, current) =
   State_domain.resolve_callee f e current
 
+type summary = State_domain.summary
+
+let pp_summary = State_domain.pp_summary
+
 let create_summary ~locals ~formals (entry, current) =
   let fs, current =
     State_domain.create_summary ~locals ~formals ~entry ~current

sledge/src/symbheap/sh_domain.mli

@@ -9,8 +9,8 @@
 
 type t
 
-val project : t -> State_domain.t
 val pp : t pp
+val report_fmt_thunk : t -> Formatter.t -> unit
 val init : Global.t vector -> t
 val join : t -> t -> t
 val is_false : t -> bool
@@ -28,16 +28,16 @@ val exec_intrinsic :
   -> (t, unit) result option
 
 type from_call [@@deriving sexp_of]
+type summary
+
+val pp_summary : summary pp
 
 (* formals should include all the parameters of the summary. That is both
    formals and globals.*)
 val create_summary :
-     locals:Var.Set.t
-  -> formals:Var.Set.t
-  -> t
-  -> State_domain.function_summary * t
+  locals:Var.Set.t -> formals:Var.Set.t -> t -> summary * t
 
-val apply_summary : t -> State_domain.function_summary -> t option
+val apply_summary : t -> summary -> t option
 
 val call :
      summaries:bool

sledge/src/symbheap/state_domain.ml

@@ -152,9 +152,9 @@ let resolve_callee lookup ptr _ =
   | Some callee_name -> lookup callee_name
   | None -> []
 
-type function_summary = {xs: Var.Set.t; foot: t; post: t}
+type summary = {xs: Var.Set.t; foot: t; post: t}
 
-let pp_function_summary fs {xs; foot; post} =
+let pp_summary fs {xs; foot; post} =
   Format.fprintf fs "@[<v>xs: @[%a@]@ foot: %a@ post: %a @]" Var.Set.pp xs
     pp foot pp post
 
@@ -184,10 +184,10 @@ let create_summary ~locals ~formals ~entry ~current:(post : Sh.t) =
   let current = Sh.extend_us xs post in
   ({xs; foot; post}, current)
   |>
-  [%Trace.retn fun {pf} (fs, _) -> pf "@,%a" pp_function_summary fs]
+  [%Trace.retn fun {pf} (fs, _) -> pf "@,%a" pp_summary fs]
 
 let apply_summary ({xs; foot; post} as fs) q =
-  [%Trace.call fun {pf} -> pf "fs: %a@ q: %a" pp_function_summary fs pp q]
+  [%Trace.call fun {pf} -> pf "fs: %a@ q: %a" pp_summary fs pp q]
   ;
   let xs_in_q = Set.inter xs q.Sh.us in
   let xs_in_fv_q = Set.inter xs (Sh.fv q) in

sledge/src/symbheap/state_domain.mli

@@ -38,10 +38,10 @@ val call :
   -> t
   -> t * from_call
 
-type function_summary = {xs: Var.Set.t; foot: t; post: t}
+type summary = {xs: Var.Set.t; foot: t; post: t}
 
-val pp_function_summary : Format.formatter -> function_summary -> unit
-val apply_summary : function_summary -> t -> t option
+val pp_summary : summary pp
+val apply_summary : summary -> t -> t option
 
 (* formals should include all the parameters of the summary. That is both
    formals and globals.*)
@@ -50,7 +50,7 @@ val create_summary :
   -> formals:Var.Set.t
   -> entry:t
   -> current:t
-  -> function_summary * t
+  -> summary * t
 
 val post : Var.Set.t -> t -> t
 val retn : Var.t list -> Var.t option -> from_call -> t -> t

sledge/src/unit_domain.ml

@@ -0,0 +1,39 @@
+(*
+ * 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.
+ *)
+
+(** "Unit" abstract domain *)
+
+type t = unit
+
+let pp fs () = Format.pp_print_string fs "()"
+let report_fmt_thunk () fs = pp fs ()
+let init _ = ()
+let join () () = ()
+let is_false _ = false
+let exec_assume () _ = Some ()
+let exec_kill () _ = ()
+let exec_move () _ _ = ()
+let exec_inst () _ = Ok ()
+let exec_intrinsic ~skip_throw:_ _ _ _ _ : (t, unit) result option = None
+
+type from_call = unit [@@deriving compare, equal, sexp]
+
+let call ~summaries:_ _ _ _ _ _ _ = ((), ())
+let post _ _ () = ()
+let retn _ _ _ _ = ()
+let dnf () = [()]
+
+let resolve_callee lookup ptr _ =
+  match Var.of_exp ptr with
+  | Some callee_name -> lookup callee_name
+  | None -> []
+
+type summary = unit
+
+let pp_summary fs () = Format.pp_print_string fs "()"
+let create_summary ~locals:_ ~formals:_ _ = ((), ())
+let apply_summary _ _ = Some ()

sledge/src/unit_domain.mli

@@ -0,0 +1,10 @@
+(*
+ * 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.
+ *)
+
+(** "Unit" abstract domain *)
+
+include Domain_sig.Dom