[sledge] Statically resolve known function calls

Summary:
The callee function of a Call can often be resolved
statically. Currently this is resolution is only done dynamically
during symbolic execution by checking if the callee expression is a
function name and looking up the function in the program. This is
wasted and redundant work. Also, the static resolution code is
duplicated in all the domains.

This diff resolves this by resolving known callees statically at
translation time. This involves:

- add an ICall terminator that is the same as Call is currently

- change Call to use a func callee instead of Exp.t

- make callee field mutable since recursive calls can create cycles

- change the Llair.Term.call constructor to return a thunk to perform
  the backpatching once the callee has been translated

- modify the Frontend

  + to determine whether to emit Call or ICall depending on whether
    the callee in LLVM is already a Function

  + to record the LLVM function -- backpatch thunk pairs encountered during translation

  + record the mapping of LLVM to LLAIR functions during translation

  + to enumerate the calls to backpatch after all functions have been
    translated, and find the LLAIR function corresponding to each LLVM
    function and backpatch the call to use it as the callee

  + to handle direct calls to undefined functions, when backpatching
    translate such function declarations into undefined functions

Reviewed By: jvillard

Differential Revision: D25146152

fbshipit-source-id: 47d2ca1ff

sledge/cli/domain_itv.ml

@@ -275,11 +275,7 @@ let call ~summaries ~globals:_ ~actuals ~areturn ~formals ~freturn:_
     (q''', {areturn; caller_q= q})
 
 let dnf q = [q]
-
-let resolve_callee lookup ptr q =
-  match Llair.Function.of_exp ptr with
-  | Some callee -> (lookup callee, q)
-  | None -> ([], q)
+let resolve_callee _ _ q = ([], q)
 
 type summary = t
 

sledge/cli/frontend.ml

@@ -378,6 +378,10 @@ let pp_prefix_exp fs (insts, exp) =
    of 'undef' to a distinct register *)
 let undef_count = ref 0
 
+module GlobTbl = LlvalueTbl
+
+let memo_global : GlobalDefn.t GlobTbl.t = GlobTbl.create ()
+
 module ValTbl = HashTable.Make (struct
   type t = bool * Llvm.llvalue
 
@@ -386,10 +390,6 @@ end)
 
 let memo_value : (Inst.t list * Exp.t) ValTbl.t = ValTbl.create ()
 
-module GlobTbl = LlvalueTbl
-
-let memo_global : GlobalDefn.t GlobTbl.t = GlobTbl.create ()
-
 let should_inline : Llvm.llvalue -> bool =
  fun llv ->
   match Llvm.use_begin llv with
@@ -1015,6 +1015,22 @@ let xlate_intrinsic_inst emit_inst x name_segs instr num_actuals loc =
     | None -> None )
   | _ -> None
 
+let calls_to_backpatch = ref []
+
+let term_call x llcallee ~typ ~actuals ~areturn ~return ~throw ~loc =
+  match Llvm.classify_value llcallee with
+  | Function ->
+      let name = Llvm.value_name llcallee in
+      let call, backpatch =
+        Term.call ~name ~typ ~actuals ~areturn ~return ~throw ~loc
+      in
+      calls_to_backpatch :=
+        (llcallee, typ, backpatch) :: !calls_to_backpatch ;
+      ([], call)
+  | _ ->
+      let prefix, callee = xlate_value x llcallee in
+      (prefix, Term.icall ~callee ~typ ~actuals ~areturn ~return ~throw ~loc)
+
 let xlate_instr :
        pop_thunk
     -> x
@@ -1073,9 +1089,9 @@ let xlate_instr :
   | Call -> (
       let llcallee = Llvm.operand instr (Llvm.num_operands instr - 1) in
       let lltyp = Llvm.type_of llcallee in
-      let llfunc = norm_callee llcallee in
-      let num_actuals = num_actuals instr lltyp llfunc in
-      let fname = Llvm.value_name llfunc in
+      let llcallee = norm_callee llcallee in
+      let num_actuals = num_actuals instr lltyp llcallee in
+      let fname = Llvm.value_name llcallee in
       let name_segs = String.split_on_char fname ~by:'.' in
       let skip msg =
         if StringS.add ignored_callees fname then
@@ -1111,32 +1127,30 @@ let xlate_instr :
           | ["llvm"; ("va_start" | "va_copy" | "va_end")] ->
               skip "variadic function intrinsic"
           | "llvm" :: _ -> skip "intrinsic"
-          | _ when Poly.equal (Llvm.classify_value llfunc) InlineAsm ->
+          | _ when Poly.equal (Llvm.classify_value llcallee) InlineAsm ->
               skip "inline asm"
           (* general function call that may not throw *)
           | _ ->
-              let pre0, callee = xlate_value x llfunc in
               let typ = xlate_type x lltyp in
               let lbl = name ^ ".ret" in
-              let pre, call =
-                let pre, actuals =
+              let pre_1, actuals =
                 xlate_values x num_actuals (Llvm.operand instr)
               in
               let areturn = xlate_name_opt x instr in
               let return = Jump.mk lbl in
-                ( pre
-                , Term.call ~callee ~typ ~actuals ~areturn ~return
-                    ~throw:None ~loc )
+              let pre_0, call =
+                term_call x llcallee ~typ ~actuals ~areturn ~return
+                  ~throw:None ~loc
               in
               continue (fun (insts, term) ->
                   let cmnd = IArray.of_list insts in
-                  (pre0 @ pre, call, [Block.mk ~lbl ~cmnd ~term]) ) ) ) )
+                  (pre_0 @ pre_1, call, [Block.mk ~lbl ~cmnd ~term]) ) ) ) )
   | Invoke -> (
       let llcallee = Llvm.operand instr (Llvm.num_operands instr - 3) in
       let lltyp = Llvm.type_of llcallee in
-      let llfunc = norm_callee llcallee in
-      let num_actuals = num_actuals instr lltyp llfunc in
-      let fname = Llvm.value_name llfunc in
+      let llcallee = norm_callee llcallee in
+      let num_actuals = num_actuals instr lltyp llcallee in
+      let fname = Llvm.value_name llcallee in
       let name_segs = String.split_on_char fname ~by:'.' in
       let return_blk = Llvm.get_normal_dest instr in
       let unwind_blk = Llvm.get_unwind_dest instr in
@@ -1169,11 +1183,10 @@ let xlate_instr :
             (* unimplemented *)
             | "llvm" :: "experimental" :: "gc" :: "statepoint" :: _ ->
                 todo "statepoints:@ %a" pp_llvalue instr ()
-            | _ when Poly.equal (Llvm.classify_value llfunc) InlineAsm ->
+            | _ when Poly.equal (Llvm.classify_value llcallee) InlineAsm ->
                 todo "inline asm: @ %a" pp_llvalue instr ()
             (* general function call that may throw *)
             | _ ->
-                let pre_0, callee = xlate_value x llfunc in
                 let typ = xlate_type x lltyp in
                 let pre_1, actuals =
                   xlate_values x num_actuals (Llvm.operand instr)
@@ -1185,12 +1198,12 @@ let xlate_instr :
                 let pre_3, throw, blocks =
                   xlate_jump x instr unwind_blk loc blocks
                 in
-                let throw = Some throw in
-                emit_term
-                  ~prefix:(List.concat [pre_0; pre_1; pre_2; pre_3])
-                  (Term.call ~callee ~typ ~actuals ~areturn ~return ~throw
-                     ~loc)
-                  ~blocks ) ) )
+                let pre_0, call =
+                  term_call x llcallee ~typ ~actuals ~areturn ~return
+                    ~throw:(Some throw) ~loc
+                in
+                let prefix = List.concat [pre_0; pre_1; pre_2; pre_3] in
+                emit_term ~prefix call ~blocks ) ) )
   | Ret ->
       let pre, exp =
         if Llvm.num_operands instr = 0 then ([], None)
@@ -1396,6 +1409,16 @@ let xlate_instr :
       fail "xlate_instr: %a" pp_llvalue instr ()
   | PHI | Invalid | Invalid2 | UserOp1 | UserOp2 -> assert false
 
+let rec xlate_instrs : pop_thunk -> x -> _ Llvm.llpos -> code =
+ fun pop x -> function
+  | Before instrI ->
+      xlate_instr pop x instrI (fun xlate_instrI ->
+          let instrJ = Llvm.instr_succ instrI in
+          let instsJ, termJ, blocksJN = xlate_instrs pop x instrJ in
+          let instsI, termI, blocksI = xlate_instrI (instsJ, termJ) in
+          (instsI, termI, blocksI @ blocksJN) )
+  | At_end blk -> fail "xlate_instrs: %a" pp_llblock blk ()
+
 let skip_phis : Llvm.llbasicblock -> _ Llvm.llpos =
  fun blk ->
   let rec skip_phis_ (pos : _ Llvm.llpos) =
@@ -1408,16 +1431,6 @@ let skip_phis : Llvm.llbasicblock -> _ Llvm.llpos =
   in
   skip_phis_ (Llvm.instr_begin blk)
 
-let rec xlate_instrs : pop_thunk -> x -> _ Llvm.llpos -> code =
- fun pop x -> function
-  | Before instrI ->
-      xlate_instr pop x instrI (fun xlate_instrI ->
-          let instrJ = Llvm.instr_succ instrI in
-          let instsJ, termJ, blocksJN = xlate_instrs pop x instrJ in
-          let instsI, termI, blocksI = xlate_instrI (instsJ, termJ) in
-          (instsI, termI, blocksI @ blocksJN) )
-  | At_end blk -> fail "xlate_instrs: %a" pp_llblock blk ()
-
 let xlate_block : pop_thunk -> x -> Llvm.llbasicblock -> Llair.block list =
  fun pop x blk ->
   [%Trace.call fun {pf} -> pf "%a" pp_llblock blk]
@@ -1433,16 +1446,11 @@ let report_undefined func name =
   if Option.is_some (Llvm.use_begin func) then
     [%Trace.info "undefined function: %a" Function.pp name]
 
-let xlate_function : x -> Llvm.llvalue -> Llair.func =
- fun x llf ->
-  [%Trace.call fun {pf} -> pf "%a" pp_llvalue llf]
-  ;
-  undef_count := 0 ;
-  let loc = find_loc llf in
-  let typ = xlate_type x (Llvm.type_of llf) in
-  let name = Function.mk typ (find_name llf) in
+let xlate_function_decl x llfunc typ k =
+  let loc = find_loc llfunc in
+  let name = Function.mk typ (find_name llfunc) in
   let formals =
-    Iter.from_iter (fun f -> Llvm.iter_params f llf)
+    Iter.from_iter (fun f -> Llvm.iter_params f llfunc)
     |> Iter.map ~f:(xlate_name x)
     |> IArray.of_iter
   in
@@ -1454,6 +1462,16 @@ let xlate_function : x -> Llvm.llvalue -> Llair.func =
   in
   let _, _, exc_typ = exception_typs in
   let fthrow = Reg.mk exc_typ "fthrow" in
+  k ~name ~formals ~freturn ~fthrow ~loc
+
+let xlate_function : x -> Llvm.llvalue -> Llair.func =
+ fun x llf ->
+  [%Trace.call fun {pf} -> pf "%a" pp_llvalue llf]
+  ;
+  undef_count := 0 ;
+  let typ = xlate_type x (Llvm.type_of llf) in
+  xlate_function_decl x llf typ
+  @@ fun ~name ~formals ~freturn ~fthrow ~loc ->
   ( match Llvm.block_begin llf with
   | Before entry_blk ->
       let pop = pop_stack_frame_of_function x llf entry_blk in
@@ -1482,6 +1500,18 @@ let xlate_function : x -> Llvm.llvalue -> Llair.func =
   |>
   [%Trace.retn fun {pf} -> pf "@\n%a" Func.pp]
 
+let backpatch_calls x func_tbl =
+  List.iter !calls_to_backpatch ~f:(fun (llfunc, typ, backpatch) ->
+      match LlvalueTbl.find func_tbl llfunc with
+      | Some callee -> backpatch ~callee
+      | None ->
+          xlate_function_decl x llfunc typ
+          @@ fun ~name ~formals ~freturn ~fthrow ~loc ->
+          let callee =
+            Func.mk_undefined ~name ~formals ~freturn ~fthrow ~loc
+          in
+          backpatch ~callee )
+
 let transform ~internalize : Llvm.llmodule -> unit =
  fun llmodule ->
   let pm = Llvm.PassManager.create () in
@@ -1558,13 +1588,14 @@ let check_datalayout llcontext lldatalayout =
    Llvm.dispose_context. *)
 let cleanup llmodule llcontext =
   SymTbl.clear sym_tbl ;
-  String.Tbl.clear realpath_tbl ;
   ScopeTbl.clear scope_tbl ;
+  String.Tbl.clear realpath_tbl ;
   LltypeTbl.clear anon_struct_name ;
   LltypeTbl.clear memo_type ;
   GlobTbl.clear memo_global ;
   ValTbl.clear memo_value ;
   StringS.clear ignored_callees ;
+  calls_to_backpatch := [] ;
   Gc.full_major () ;
   Llvm.dispose_module llmodule ;
   Llvm.dispose_context llcontext
@@ -1608,6 +1639,7 @@ let translate ~models ~fuzzer ~internalize : string list -> Llair.program =
         else xlate_global x llg :: globals )
       [] llmodule
   in
+  let func_tbl : Func.t LlvalueTbl.t = LlvalueTbl.create () in
   let functions =
     Llvm.fold_left_functions
       (fun functions llf ->
@@ -1616,9 +1648,13 @@ let translate ~models ~fuzzer ~internalize : string list -> Llair.program =
           String.prefix name ~pre:"__llair_"
           || String.prefix name ~pre:"llvm."
         then functions
-        else xlate_function x llf :: functions )
+        else
+          let func = xlate_function x llf in
+          LlvalueTbl.set func_tbl ~key:llf ~data:func ;
+          func :: functions )
       [] llmodule
   in
+  backpatch_calls x func_tbl ;
   cleanup llmodule llcontext ;
   Llair.Program.mk ~globals ~functions
   |>

sledge/src/control.ml

@@ -308,6 +308,24 @@ module Make (Dom : Domain_intf.Dom) = struct
     |>
     [%Trace.retn fun {pf} _ -> pf ""]
 
+  let exec_skip_func :
+         Stack.t
+      -> Dom.t
+      -> Llair.block
+      -> Llair.Reg.t option
+      -> Llair.jump
+      -> Work.x =
+   fun stk state block areturn return ->
+    Report.unknown_call block.term ;
+    let state = Option.fold ~f:Dom.exec_kill areturn state in
+    exec_jump stk state block return
+
+  let exec_call opts stk state block
+      ({Llair.callee; areturn; return; _} as call) globals =
+    if Llair.Func.is_undefined callee then
+      exec_skip_func stk state block areturn return
+    else exec_call opts stk state block call globals
+
   let pp_st () =
     [%Trace.printf
       "@[<v>%t@]" (fun fs ->
@@ -376,18 +394,6 @@ module Make (Dom : Domain_intf.Dom) = struct
     |>
     [%Trace.retn fun {pf} _ -> pf ""]
 
-  let exec_skip_func :
-         Stack.t
-      -> Dom.t
-      -> Llair.block
-      -> Llair.Reg.t option
-      -> Llair.jump
-      -> Work.x =
-   fun stk state block areturn return ->
-    Report.unknown_call block.term ;
-    let state = Option.fold ~f:Dom.exec_kill areturn state in
-    exec_jump stk state block return
-
   let exec_term :
          exec_opts
       -> Llair.program
@@ -425,7 +431,10 @@ module Make (Dom : Domain_intf.Dom) = struct
             with
             | Some state -> exec_jump stk state block jump |> Work.seq x
             | None -> x )
-    | Call ({callee; areturn; return} as call) -> (
+    | Call ({callee} as call) ->
+        exec_call opts stk state block call
+          (Domain_used_globals.by_function opts.globals callee.name)
+    | ICall ({callee; areturn; return} as call) -> (
         let lookup name =
           Option.to_list (Llair.Func.find name pgm.functions)
         in
@@ -434,12 +443,8 @@ module Make (Dom : Domain_intf.Dom) = struct
         | [] -> exec_skip_func stk state block areturn return
         | callees ->
             List.fold callees Work.skip ~f:(fun callee x ->
-                ( if Llair.Func.is_undefined callee then
-                  exec_skip_func stk state block areturn return
-                else
                 exec_call opts stk state block {call with callee}
-                    (Domain_used_globals.by_function opts.globals
-                       callee.name) )
+                  (Domain_used_globals.by_function opts.globals callee.name)
                 |> Work.seq x ) )
     | Return {exp} -> exec_return ~opts stk state block exp
     | Throw {exc} ->

sledge/src/domain_unit.ml

@@ -29,11 +29,7 @@ let recursion_beyond_bound = `skip
 let post _ _ () = ()
 let retn _ _ _ _ = ()
 let dnf () = [()]
-
-let resolve_callee lookup ptr _ =
-  match Llair.Function.of_exp ptr with
-  | Some callee -> (lookup callee, ())
-  | None -> ([], ())
+let resolve_callee _ _ q = ([], q)
 
 type summary = unit
 

sledge/src/domain_used_globals.ml

@@ -52,11 +52,7 @@ let call ~summaries:_ ~globals:_ ~actuals ~areturn:_ ~formals:_ ~freturn:_
     ~locals:_ st =
   (empty, IArray.fold ~f:used_globals actuals st)
 
-let resolve_callee lookup ptr st =
-  let st = used_globals ptr st in
-  match Llair.Function.of_exp ptr with
-  | Some callee -> (lookup callee, st)
-  | None -> ([], st)
+let resolve_callee _ _ q = ([], q)
 
 (* A function summary is the set of global registers accessed by that
    function and its transitive callees *)

sledge/src/llair/llair.ml

@@ -53,7 +53,7 @@ type label = string [@@deriving compare, equal, hash, sexp]
 type jump = {mutable dst: block; mutable retreating: bool}
 
 and 'a call =
-  { callee: 'a
+  { mutable callee: 'a
   ; typ: Typ.t
   ; actuals: Exp.t iarray
   ; areturn: Reg.t option
@@ -65,7 +65,8 @@ and 'a call =
 and term =
   | Switch of {key: Exp.t; tbl: (Exp.t * jump) iarray; els: jump; loc: Loc.t}
   | Iswitch of {ptr: Exp.t; tbl: jump iarray; loc: Loc.t}
-  | Call of Exp.t call
+  | Call of func call
+  | ICall of Exp.t call
   | Return of {exp: Exp.t option; loc: Loc.t}
   | Throw of {exc: Exp.t; loc: Loc.t}
   | Unreachable
@@ -112,7 +113,7 @@ with type jump := jump
   [@@deriving compare, equal]
 
   type nonrec 'a call = 'a call =
-    { callee: 'a
+    { mutable callee: 'a
     ; typ: Typ.t
     ; actuals: Exp.t iarray
     ; areturn: Reg.t option
@@ -126,7 +127,8 @@ with type jump := jump
     | Switch of
         {key: Exp.t; tbl: (Exp.t * jump) iarray; els: jump; loc: Loc.t}
     | Iswitch of {ptr: Exp.t; tbl: jump iarray; loc: Loc.t}
-    | Call of Exp.t call
+    | Call of func call
+    | ICall of Exp.t call
     | Return of {exp: Exp.t option; loc: Loc.t}
     | Throw of {exc: Exp.t; loc: Loc.t}
     | Unreachable
@@ -142,6 +144,19 @@ let hash_fold_jump s {dst; retreating} =
   let s = [%hash_fold: bool] s retreating in
   s
 
+let hash_fold_call (type callee) hash_fold_callee s
+    {callee: callee; typ; actuals; areturn; return; throw; recursive; loc} =
+  let s = [%hash_fold: int] s 3 in
+  let s = [%hash_fold: callee] s callee in
+  let s = [%hash_fold: Typ.t] s typ in
+  let s = [%hash_fold: Exp.t iarray] s actuals in
+  let s = [%hash_fold: Reg.t option] s areturn in
+  let s = [%hash_fold: jump] s return in
+  let s = [%hash_fold: jump option] s throw in
+  let s = [%hash_fold: bool] s recursive in
+  let s = [%hash_fold: Loc.t] s loc in
+  s
+
 let hash_fold_term s = function
   | Switch {key; tbl; els; loc} ->
       let s = [%hash_fold: int] s 1 in
@@ -156,28 +171,25 @@ let hash_fold_term s = function
       let s = [%hash_fold: jump iarray] s tbl in
       let s = [%hash_fold: Loc.t] s loc in
       s
-  | Call {callee; typ; actuals; areturn; return; throw; recursive; loc} ->
+  | Call call ->
       let s = [%hash_fold: int] s 3 in
-      let s = [%hash_fold: Exp.t] s callee in
-      let s = [%hash_fold: Typ.t] s typ in
-      let s = [%hash_fold: Exp.t iarray] s actuals in
-      let s = [%hash_fold: Reg.t option] s areturn in
-      let s = [%hash_fold: jump] s return in
-      let s = [%hash_fold: jump option] s throw in
-      let s = [%hash_fold: bool] s recursive in
-      let s = [%hash_fold: Loc.t] s loc in
+      let s = hash_fold_call hash_fold_func s call in
       s
-  | Return {exp; loc} ->
+  | ICall call ->
       let s = [%hash_fold: int] s 4 in
+      let s = hash_fold_call Exp.hash_fold_t s call in
+      s
+  | Return {exp; loc} ->
+      let s = [%hash_fold: int] s 5 in
       let s = [%hash_fold: Exp.t option] s exp in
       let s = [%hash_fold: Loc.t] s loc in
       s
   | Throw {exc; loc} ->
-      let s = [%hash_fold: int] s 5 in
+      let s = [%hash_fold: int] s 6 in
       let s = [%hash_fold: Exp.t] s exc in
       let s = [%hash_fold: Loc.t] s loc in
       s
-  | Unreachable -> [%hash_fold: int] s 6
+  | Unreachable -> [%hash_fold: int] s 7
 
 let hash_func = Hash.of_fold hash_fold_func
 let hash_block = Hash.of_fold hash_fold_block
@@ -196,17 +208,11 @@ let sexp_ctor label args = sexp_cons (Sexp.Atom label) args
 let sexp_of_jump {dst; retreating} =
   [%sexp {dst: label = dst.lbl; retreating: bool}]
 
-let sexp_of_term = function
-  | Switch {key; tbl; els; loc} ->
-      sexp_ctor "Switch"
+let sexp_of_call (type callee) tag sexp_of_callee
+    {callee: callee; typ; actuals; areturn; return; throw; recursive; loc} =
+  sexp_ctor tag
     [%sexp
-          {key: Exp.t; tbl: (Exp.t * jump) iarray; els: jump; loc: Loc.t}]
-  | Iswitch {ptr; tbl; loc} ->
-      sexp_ctor "Iswitch" [%sexp {ptr: Exp.t; tbl: jump iarray; loc: Loc.t}]
-  | Call {callee; typ; actuals; areturn; return; throw; recursive; loc} ->
-      sexp_ctor "Call"
-        [%sexp
-          { callee: Exp.t
+      { callee: callee
       ; typ: Typ.t
       ; actuals: Exp.t iarray
       ; areturn: Reg.t option
@@ -214,6 +220,17 @@ let sexp_of_term = function
       ; throw: jump option
       ; recursive: bool
       ; loc: Loc.t }]
+
+let sexp_of_term = function
+  | Switch {key; tbl; els; loc} ->
+      sexp_ctor "Switch"
+        [%sexp
+          {key: Exp.t; tbl: (Exp.t * jump) iarray; els: jump; loc: Loc.t}]
+  | Iswitch {ptr; tbl; loc} ->
+      sexp_ctor "Iswitch" [%sexp {ptr: Exp.t; tbl: jump iarray; loc: Loc.t}]
+  | Call call ->
+      sexp_of_call "Call" (fun f -> Function.sexp_of_t f.name) call
+  | ICall call -> sexp_of_call "ICall" Exp.sexp_of_t call
   | Return {exp; loc} ->
       sexp_ctor "Return" [%sexp {exp: Exp.t option; loc: Loc.t}]
   | Throw {exc; loc} -> sexp_ctor "Throw" [%sexp {exc: Exp.t; loc: Loc.t}]
@@ -281,6 +298,17 @@ let pp_jump fs {dst; retreating} =
     (if retreating then "↑" else "")
     dst.lbl
 
+let pp_call tag pp_callee fs
+    {callee; actuals; areturn; return; throw; recursive; loc; _} =
+  Format.fprintf fs
+    "@[<2>@[<7>%a%s @[<2>%s%a%a@]@]@ @[returnto %a%a;@]@]\t%a"
+    (Option.pp "%a := " Reg.pp)
+    areturn tag
+    (if recursive then "↑" else "")
+    pp_callee callee (pp_actuals Exp.pp) actuals pp_jump return
+    (Option.pp "@ throwto %a" pp_jump)
+    throw Loc.pp loc
+
 let pp_term fs term =
   let pf pp = Format.fprintf fs pp in
   let pp_goto fs jmp = Format.fprintf fs "goto %a;" pp_jump jmp in
@@ -301,14 +329,8 @@ let pp_term fs term =
         (IArray.pp "@ " (fun fs jmp ->
              Format.fprintf fs "%s: %a" jmp.dst.lbl pp_goto jmp ))
         tbl Loc.pp loc
-  | Call {callee; actuals; areturn; return; throw; recursive; loc; _} ->
-      pf "@[<2>@[<7>%acall @[<2>%s%a%a@]@]@ @[returnto %a%a;@]@]\t%a"
-        (Option.pp "%a := " Reg.pp)
-        areturn
-        (if recursive then "↑" else "")
-        Exp.pp callee (pp_actuals Exp.pp) actuals pp_jump return
-        (Option.pp "@ throwto %a" pp_jump)
-        throw Loc.pp loc
+  | Call call -> pp_call "call" (fun fs f -> Function.pp fs f.name) fs call
+  | ICall call -> pp_call "icall" Exp.pp fs call
   | Return {exp; loc} ->
       pf "@[<2>return%a@]\t%a" (Option.pp " %a" Exp.pp) exp Loc.pp loc
   | Throw {exc; loc} -> pf "@[<2>throw %a@]\t%a" Exp.pp exc Loc.pp loc
@@ -431,7 +453,8 @@ module Term = struct
     let@ () = Invariant.invariant [%here] term [%sexp_of: t] in
     match term with
     | Switch _ | Iswitch _ -> assert true
-    | Call {typ; actuals; areturn; _} -> (
+    | Call {typ; actuals; areturn; _} | ICall {typ; actuals; areturn; _}
+      -> (
       match typ with
       | Pointer {elt= Function {args; return= retn_typ; _}} ->
           assert (IArray.length args = IArray.length actuals) ;
@@ -460,8 +483,22 @@ module Term = struct
 
   let iswitch ~ptr ~tbl ~loc = Iswitch {ptr; tbl; loc} |> check invariant
 
-  let call ~callee ~typ ~actuals ~areturn ~return ~throw ~loc =
-    Call
+  let call ~name ~typ ~actuals ~areturn ~return ~throw ~loc =
+    let cal =
+      { callee= {dummy_func with name= Function.mk typ name}
+      ; typ
+      ; actuals
+      ; areturn
+      ; return
+      ; throw
+      ; recursive= false
+      ; loc }
+    in
+    let k = Call cal in
+    (k |> check invariant, fun ~callee -> cal.callee <- callee)
+
+  let icall ~callee ~typ ~actuals ~areturn ~return ~throw ~loc =
+    ICall
       {callee; typ; actuals; areturn; return; throw; recursive= false; loc}
     |> check invariant
 
@@ -473,6 +510,7 @@ module Term = struct
     | Switch {loc; _}
      |Iswitch {loc; _}
      |Call {loc; _}
+     |ICall {loc; _}
      |Return {loc; _}
      |Throw {loc; _} ->
         loc
@@ -480,8 +518,9 @@ module Term = struct
 
   let union_locals term vs =
     match term with
-    | Call {areturn; _} -> Reg.Set.add_option areturn vs
-    | _ -> vs
+    | Call {areturn; _} | ICall {areturn; _} ->
+        Reg.Set.add_option areturn vs
+    | Switch _ | Iswitch _ | Return _ | Throw _ | Unreachable -> vs
 end
 
 (** Basic-Blocks *)
@@ -527,7 +566,6 @@ end
 
 module BlockS = HashSet.Make (Block_label)
 module BlockQ = HashQueue.Make (Block_label)
-module FuncQ = HashQueue.Make (Function)
 
 (** Functions *)
 
@@ -550,7 +588,8 @@ module Func = struct
               let s = IArray.fold ~f:(fun (_, j) -> f j) tbl s in
               f els s
           | Iswitch {tbl; _} -> IArray.fold ~f tbl s
-          | Call {return; throw; _} -> Option.fold ~f throw (f return s)
+          | Call {return; throw; _} | ICall {return; throw; _} ->
+              Option.fold ~f throw (f return s)
           | Return _ | Throw _ | Unreachable -> s
         in
         f blk s
@@ -624,7 +663,7 @@ module Func = struct
           IArray.iter tbl ~f:(fun (_, jmp) -> set_dst jmp) ;
           set_dst els
       | Iswitch {tbl; _} -> IArray.iter tbl ~f:set_dst
-      | Call {return; throw; _} ->
+      | Call {return; throw; _} | ICall {return; throw; _} ->
           set_dst return ;
           Option.iter throw ~f:set_dst
       | Return _ | Throw _ | Unreachable -> ()
@@ -643,23 +682,22 @@ end
 
 (** Derived meta-data *)
 
+module FuncQ = HashQueue.Make (Func)
+
 let set_derived_metadata functions =
   let compute_roots functions =
     let roots = FuncQ.create () in
     Function.Map.iter functions ~f:(fun func ->
-        FuncQ.enqueue_back_exn roots func.name func ) ;
+        FuncQ.enqueue_back_exn roots func func ) ;
     Function.Map.iter functions ~f:(fun func ->
         Func.iter_term func ~f:(fun term ->
             match term with
-            | Call {callee; _} -> (
-              match Function.of_exp callee with
-              | Some callee ->
+            | Call {callee; _} ->
                 FuncQ.remove roots callee |> (ignore : [> ] -> unit)
-              | None -> () )
             | _ -> () ) ) ;
     roots
   in
-  let topsort functions roots =
+  let topsort roots =
     let tips_to_roots = BlockQ.create () in
     let rec visit ancestors func src =
       if BlockQ.mem tips_to_roots src then ()
@@ -675,18 +713,15 @@ let set_derived_metadata functions =
             IArray.iter tbl ~f:(fun (_, jmp) -> jump jmp) ;
             jump els
         | Iswitch {tbl; _} -> IArray.iter tbl ~f:jump
-        | Call ({callee; return; throw; _} as call) ->
-            ( match
-                let* name = Function.of_exp callee in
-                Func.find name functions
-              with
-            | Some func ->
-                if Block_label.Set.mem func.entry ancestors then
-                  call.recursive <- true
-                else visit ancestors func func.entry
-            | None ->
-                (* conservatively assume all virtual calls are recursive *)
-                call.recursive <- true ) ;
+        | Call ({callee; return; throw; _} as cal) ->
+            if Block_label.Set.mem callee.entry ancestors then
+              cal.recursive <- true
+            else visit ancestors func callee.entry ;
+            jump return ;
+            Option.iter ~f:jump throw
+        | ICall ({return; throw; _} as call) ->
+            (* conservatively assume all indirect calls are recursive *)
+            call.recursive <- true ;
             jump return ;
             Option.iter ~f:jump throw
         | Return _ | Throw _ | Unreachable -> () ) ;
@@ -707,7 +742,7 @@ let set_derived_metadata functions =
         Function.Map.add_exn ~key:func.name ~data:func m )
   in
   let roots = compute_roots functions in
-  let tips_to_roots = topsort functions roots in
+  let tips_to_roots = topsort roots in
   set_sort_indices tips_to_roots ;
   functions
 

sledge/src/llair/llair.mli

@@ -54,11 +54,11 @@ type cmnd = inst iarray
 type label = string
 
 (** A jump to a block. *)
-type jump = {mutable dst: block; mutable retreating: bool}
+type jump = private {mutable dst: block; mutable retreating: bool}
 
 (** A call to a function. *)
 and 'a call =
-  { callee: 'a
+  { mutable callee: 'a
   ; typ: Typ.t  (** Type of the callee. *)
   ; actuals: Exp.t iarray  (** Actual arguments. *)
   ; areturn: Reg.t option  (** Register to receive return value. *)
@@ -75,8 +75,8 @@ and term = private
           [case] which is equal to [key], if any, otherwise invoke [els]. *)
   | Iswitch of {ptr: Exp.t; tbl: jump iarray; loc: Loc.t}
       (** Invoke the [jump] in [tbl] whose [dst] is equal to [ptr]. *)
-  | Call of Exp.t call
-      (** Call function with arguments. A [global] for non-virtual call. *)
+  | Call of func call  (** Call function with arguments. *)
+  | ICall of Exp.t call  (** Indirect call function with arguments. *)
   | Return of {exp: Exp.t option; loc: Loc.t}
       (** Invoke [return] of the dynamically most recent [Call]. *)
   | Throw of {exc: Exp.t; loc: Loc.t}
@@ -162,6 +162,16 @@ module Term : sig
   val iswitch : ptr:Exp.t -> tbl:jump iarray -> loc:Loc.t -> term
 
   val call :
+       name:string
+    -> typ:Typ.t
+    -> actuals:Exp.t iarray
+    -> areturn:Reg.t option
+    -> return:jump
+    -> throw:jump option
+    -> loc:Loc.t
+    -> t * (callee:func -> unit)
+
+  val icall :
        callee:Exp.t
     -> typ:Typ.t
     -> actuals:Exp.t iarray

sledge/src/report.ml

@@ -14,7 +14,10 @@ let unknown_call call =
       (fun fs call -> Llair.Loc.pp fs (Llair.Term.loc call))
       call
       (fun fs (call : Llair.Term.t) ->
-        match call with Call {callee} -> Llair.Exp.pp fs callee | _ -> () )
+        match call with
+        | Call {callee} -> Llair.Function.pp fs callee.name
+        | ICall {callee} -> Llair.Exp.pp fs callee
+        | _ -> () )
       call Llair.Term.pp call]
 
 let invalid_access_count = ref 0