From f3d25d3a239540f013b65d8f831f290da3994625 Mon Sep 17 00:00:00 2001
From: Josh Berdine <jjb@fb.com>
Date: Wed, 17 Oct 2018 02:24:23 -0700
Subject: [PATCH] [sledge] Refactor issue reporting to Report module

Summary:
Also for debugging support, note that analysis can be stopped after
reporting an attempt to call an unknown function with `sledge
-tReport.unknown_call` and likewise for invalid memory accesses with
`sledge -tReport.invalid_access`.

Reviewed By: mbouaziz

Differential Revision: D10389474

fbshipit-source-id: b006480d3
---
 sledge/src/control.ml | 26 ++------------------------
 sledge/src/report.ml  | 37 +++++++++++++++++++++++++++++++++++++
 sledge/src/report.mli | 11 +++++++++++
 3 files changed, 50 insertions(+), 24 deletions(-)
 create mode 100644 sledge/src/report.ml
 create mode 100644 sledge/src/report.mli

diff --git a/sledge/src/control.ml b/sledge/src/control.ml
index fb1a4e86d..03b3ed116 100644
--- a/sledge/src/control.ml
+++ b/sledge/src/control.ml
@@ -166,20 +166,7 @@ let exec_throw stk state block exc =
 let exec_skip_func :
     stack -> Domain.t -> Llair.block -> Llair.jump -> Work.x =
  fun stk state block ({dst; args} as return) ->
-  Format.eprintf
-    "@\n\
-     @[<v 2>%a Called unknown function %a executing instruction@;<1 \
-     2>@[%a@]@]@."
-    Loc.pp
-    (Llair.Term.loc block.term)
-    (fun fs (term : Llair.Term.t) ->
-      match term with
-      | Call {call= {dst}} -> (
-        match Var.of_exp dst with
-        | Some var -> Var.pp_demangled fs var
-        | None -> Exp.pp fs dst )
-      | _ -> () )
-    block.term Llair.Term.pp block.term ;
+  Report.unknown_call block.term ;
   let return =
     if List.is_empty dst.params then return
     else
@@ -247,16 +234,7 @@ let exec_block : Llair.t -> stack -> Domain.t -> Llair.block -> Work.x =
   [%Trace.info "exec %a" Llair.Block.pp block] ;
   match Vector.fold_result ~f:Domain.exec_inst ~init:state block.cmnd with
   | Ok state -> exec_term pgm stk state block
-  | Error (q, i) ->
-      Format.printf
-        "@\n\
-         @[<v 2>%a Invalid memory access executing instruction@;<1 \
-         2>@[%a@]%t@]@."
-        Loc.pp (Llair.Inst.loc i) Llair.Inst.pp i (fun fs ->
-          if Version.debug then
-            Format.fprintf fs "@ from symbolic state@;<1 2>@[%a@]" Domain.pp
-              q ) ;
-      Work.skip
+  | Error (q, i) -> Report.invalid_access i q ; Work.skip
 
 let harness : Llair.t -> Work.t option =
  fun pgm ->
diff --git a/sledge/src/report.ml b/sledge/src/report.ml
new file mode 100644
index 000000000..1d939da5d
--- /dev/null
+++ b/sledge/src/report.ml
@@ -0,0 +1,37 @@
+(*
+ * Copyright (c) 2018-present, Facebook, Inc.
+ *
+ * This source code is licensed under the MIT license found in the
+ * LICENSE file in the root directory of this source tree.
+ *)
+
+(** Issue reporting *)
+
+let unknown_call call =
+  [%Trace.kprintf
+    (fun _ -> assert false)
+      "@\n\
+       @[<v 2>%a Called unknown function %a executing instruction@;<1 \
+       2>@[%a@]@]@."
+      (fun fs call -> Loc.pp fs (Llair.Term.loc call))
+      call
+      (fun fs (call : Llair.Term.t) ->
+        match call with
+        | Call {call= {dst}} -> (
+          match Var.of_exp dst with
+          | Some var -> Var.pp_demangled fs var
+          | None -> Exp.pp fs dst )
+        | _ -> () )
+      call Llair.Term.pp call]
+
+let invalid_access inst state =
+  Format.printf
+    "@\n\
+     @[<v 2>%a Invalid memory access executing instruction@;<1 2>@[%a@]@]@."
+    Loc.pp (Llair.Inst.loc inst) Llair.Inst.pp inst ;
+  [%Trace.kprintf
+    (fun _ -> assert false)
+      "@\n\
+       @[<v 2>%a Invalid memory access executing instruction@;<1 2>@[%a@]@ \
+       from symbolic state@;<1 2>@[{ %a@ }@]@]@."
+      Loc.pp (Llair.Inst.loc inst) Llair.Inst.pp inst Domain.pp state]
diff --git a/sledge/src/report.mli b/sledge/src/report.mli
new file mode 100644
index 000000000..9323d38a2
--- /dev/null
+++ b/sledge/src/report.mli
@@ -0,0 +1,11 @@
+(*
+ * Copyright (c) 2018-present, Facebook, Inc.
+ *
+ * This source code is licensed under the MIT license found in the
+ * LICENSE file in the root directory of this source tree.
+ *)
+
+(** Issue reporting *)
+
+val unknown_call : Llair.term -> unit
+val invalid_access : Llair.inst -> Domain.t -> unit