diff --git a/lib/bap_disasm/bap_disasm_insn.ml b/lib/bap_disasm/bap_disasm_insn.ml index daf58300a..333b3d03e 100644 --- a/lib/bap_disasm/bap_disasm_insn.ml +++ b/lib/bap_disasm/bap_disasm_insn.ml @@ -230,58 +230,55 @@ module Slot = struct domain end - -type vis = { - jump : bool; - cond : bool; - indirect : bool; -} - -let lookup_jumps bil = - let jump ?(cond=false) v = { v with jump = true; cond } in - let conditional v = jump ~cond:true v in - let indirect f v = f { v with indirect=true } in - let cons check x xs = if check then x :: xs else xs in - (object - inherit [vis] Stmt.visitor - method! enter_jmp ex vis = match ex with - | Bil.Int _ when under_condition -> conditional vis - | Bil.Int _ -> jump vis - | _ when under_condition -> indirect conditional vis - | _ -> indirect jump vis - end)#run bil {jump=false;cond=false;indirect=false} |> fun v -> - if not v.jump then [] - else - cons (not v.cond) `Unconditional_branch [] |> - cons v.cond `Conditional_branch |> - cons v.indirect `Indirect_branch - -let lookup_side_effects bil = (object - inherit [kind list] Stmt.visitor - method! enter_store ~mem:_ ~addr:_ ~exp:_ _ _ acc = - `May_store :: acc - method! enter_load ~mem:_ ~addr:_ _ _ acc = - `May_load :: acc -end)#run bil [] - -let (<--) slot value insn = KB.Value.put slot insn value - -let write init ops = - List.fold ~init ops ~f:(fun init f -> f init) +module Analyzer = struct + module Effects = Set.Make(struct + type t = Kind.t [@@deriving compare, sexp] + end) + type vis = { + jump : bool; + cond : bool; + indirect : bool; + } + + let no_jumps = {jump=false;cond=false;indirect=false} + + let analyzer = + let jump ?(cond=false) v = { v with jump = true; cond } in + let conditional v = jump ~cond:true v in + let indirect f v = f { v with indirect=true } in + object + inherit [Effects.t * vis] Stmt.visitor + method! enter_store ~mem:_ ~addr:_ ~exp:_ _ _ (effs,jumps) = + Set.add effs `May_store,jumps + method! enter_load ~mem:_ ~addr:_ _ _ (effs,jumps) = + Set.add effs `May_load,jumps + method! enter_jmp ex (effs,jumps) = effs,match ex with + | Bil.Int _ when under_condition -> conditional jumps + | Bil.Int _ -> jump jumps + | _ when under_condition -> indirect conditional jumps + | _ -> indirect jump jumps + end + + let run bil = + let cons c = Fn.flip @@ if c then Effects.add else Fn.const in + let effs,jump = analyzer#run bil (Effects.empty,no_jumps) in + if not jump.jump then effs + else + cons (not jump.cond) `Unconditional_branch effs |> + cons jump.cond `Conditional_branch |> + cons jump.indirect `Indirect_branch +end let derive_props ?bil insn = - let bil_kinds = match bil with - | Some bil -> lookup_jumps bil @ lookup_side_effects bil - | None -> [] in + let bil_effects = match bil with + | Some bil -> Analyzer.run bil + | None -> Analyzer.Effects.empty in let is = Insn.is insn in - let is_bil kind = - if Option.is_some bil - then List.mem ~equal:[%compare.equal : kind] bil_kinds kind - else is kind in + let is_bil = if Option.is_some bil + then Analyzer.Effects.mem bil_effects else is in (* those two are the only which we can't get from the BIL semantics *) let is_return = is `Return in let is_call = is `Call in - let is_conditional_jump = is_bil `Conditional_branch in let is_jump = is_conditional_jump || is_bil `Unconditional_branch in let is_indirect_jump = is_bil `Indirect_branch in @@ -302,6 +299,11 @@ let derive_props ?bil insn = Props.set_if may_load load |> Props.set_if may_store store +let (<--) slot value insn = KB.Value.put slot insn value + +let write init ops = + List.fold ~init ops ~f:(fun init f -> f init) + let set_basic effect insn : t = write effect Slot.[ name <-- Insn.name insn;