[Patron] make DB

src/bugPatDB.ml

@@ -0,0 +1,58 @@
+open Core
+module F = Format
+module L = Logger
+module Hashtbl = Stdlib.Hashtbl
+module Set = Stdlib.Set
+module Map = Stdlib.Map
+module Sys = Stdlib.Sys
+
+let preproc_using_pattern z3env maps src snk facts out_dir i
+    (pattern_in_numeral, pattern, diff) =
+  let i_str = string_of_int i in
+  Chc.sexp_dump (Filename.concat out_dir "pattern_" ^ i_str) pattern;
+  Chc.pretty_dump (Filename.concat out_dir "pattern_" ^ i_str) pattern;
+  Maps.dump "buggy" maps out_dir;
+  L.info "Try matching with buggy numeral...";
+  ( Chc.match_and_log z3env out_dir ("buggy_numer_" ^ i_str) maps facts src snk
+      pattern_in_numeral
+  |> fun status -> assert (Option.is_some status) );
+  Maps.dump ("buggy_numer_" ^ i_str) maps out_dir;
+  let src_oc = Filename.concat out_dir "src" in
+  Out_channel.write_all src_oc ~data:src;
+  let snk_oc = Filename.concat out_dir "snk" in
+  Out_channel.write_all snk_oc ~data:snk;
+  let diff_oc =
+    Filename.concat out_dir ("abs_diff_" ^ i_str ^ ".marshal")
+    |> Out_channel.create
+  in
+  Marshal.to_channel diff_oc diff [];
+  Out_channel.close diff_oc
+
+let run z3env inline_funcs write_out true_alarm buggy_dir patch_dir out_dir =
+  let buggy_ast = Parser.parse_ast buggy_dir inline_funcs in
+  let patch_ast = Parser.parse_ast patch_dir inline_funcs in
+  L.info "Constructing AST diff...";
+  let ast_diff = Diff.define_diff out_dir buggy_ast patch_ast in
+  let facts, (src, snk, alarm_exps, alarm_lvs), maps =
+    Parser.make_facts buggy_dir true_alarm buggy_ast out_dir
+  in
+  L.info "Making Facts in buggy done";
+  L.info "Making DUG...";
+  let dug = Dug.of_facts maps.lval_map maps.cmd_map facts in
+  L.info "Making DUG is done";
+  L.info "Making Abstract Diff...";
+  let abs_diff, patch_comps =
+    AbsDiff.define_abs_diff maps buggy_ast dug ast_diff
+  in
+  L.info "Making Abstract Diff is done";
+  if write_out then (
+    L.info "Writing out the edit script...";
+    DiffJson.dump abs_diff out_dir);
+  let patterns =
+    AbsPat.run maps dug patch_comps alarm_exps alarm_lvs src snk facts abs_diff
+  in
+  L.info "Making Bug Pattern is done";
+  List.iteri
+    ~f:(preproc_using_pattern z3env maps src snk facts out_dir)
+    patterns;
+  L.info "Preprocessing with pattern is done."

src/doEdit.ml

@@ -0,0 +1,276 @@
+open Core
+module S = AbsDiff
+module D = Diff
+module EF = EditFunction
+module H = Utils
+module L = Logger
+
+let is_patched = ref false
+
+let partition mid stmts =
+  let blst, _, alst =
+    List.fold_left
+      ~f:(fun (blst, found, alst) stmt ->
+        if not found then
+          if phys_equal stmt mid then (blst, true, alst)
+          else (stmt :: blst, found, alst)
+        else (blst, found, stmt :: alst))
+      ~init:([], false, []) stmts
+  in
+  (List.rev blst, List.rev alst)
+
+type insert_mode = Before | After
+
+let insert_internal ?(using = Before) ?(update = false) assist_opt patch stmts =
+  if Option.is_none assist_opt then
+    let stmts = List.rev stmts in
+    match using with Before -> patch @ stmts | After -> stmts @ patch
+  else
+    let assist = Option.value_exn assist_opt in
+    let rev_or_not = match using with Before -> Fun.id | After -> List.rev in
+    let new_stmts, patched =
+      List.fold_left
+        ~f:(fun (new_stmts, patched) stmt ->
+          if phys_equal stmt assist || (update && Ast.is_cil_goto stmt.Cil.skind)
+          then (rev_or_not patch @ (assist :: new_stmts), true)
+          else (stmt :: new_stmts, patched))
+        ~init:([], false) (rev_or_not stmts)
+    in
+    let new_stmts = rev_or_not new_stmts in
+    if patched then new_stmts
+    else
+      match using with
+      | Before -> new_stmts @ patch
+      | After -> patch @ new_stmts
+
+let insert_ss ?(using = Before) ?(update = false) before_opt after_opt patch
+    stmts =
+  let mid, assist_opt =
+    match using with
+    | Before -> (Option.value_exn before_opt, after_opt)
+    | After -> (Option.value_exn after_opt, before_opt)
+  in
+  let blst, alst = partition mid stmts in
+  match mid.Cil.skind with
+  | Cil.Loop (block, loc, t1, t2) ->
+      let new_b_stmts =
+        insert_internal ~using ~update assist_opt patch (List.rev block.bstmts)
+      in
+      let new_stmt =
+        Cil.Loop ({ block with bstmts = new_b_stmts }, loc, t1, t2)
+      in
+      blst @ [ { mid with skind = new_stmt } ] @ alst
+  | Cil.If (e, tb, fb, loc) ->
+      (* TODO: check true branch false branch *)
+      if List.is_empty tb.bstmts then
+        let new_b_stmts =
+          insert_internal ~update assist_opt patch (List.rev tb.bstmts)
+        in
+        let new_stmt = Cil.If (e, { tb with bstmts = new_b_stmts }, fb, loc) in
+        blst @ [ { mid with skind = new_stmt } ] @ alst
+      else
+        let new_b_stmts =
+          insert_internal ~update assist_opt patch (List.rev fb.bstmts)
+        in
+        let new_stmt = Cil.If (e, tb, { fb with bstmts = new_b_stmts }, loc) in
+        blst @ [ { mid with skind = new_stmt } ] @ alst
+  | _ -> (
+      match using with
+      | Before ->
+          let new_alst =
+            insert_internal ~update assist_opt patch (List.rev alst)
+          in
+          blst @ [ mid ] @ new_alst
+      | After ->
+          let new_blst =
+            insert_internal ~update assist_opt patch (List.rev blst)
+          in
+          new_blst @ [ mid ] @ alst)
+
+let is_in_stmt s_opt b =
+  let s = Option.value_exn s_opt in
+  List.exists ~f:(fun stmt -> phys_equal s stmt) b.Cil.bstmts
+
+class insertStmtFuncVisitor ?(update = false) before after ss =
+  object
+    inherit Cil.nopCilVisitor
+
+    method! vblock b =
+      if Option.is_some before then
+        if is_in_stmt before b then (
+          let new_stmts = insert_ss ~update before after ss b.bstmts in
+          is_patched := true;
+          ChangeTo { b with bstmts = new_stmts })
+        else DoChildren
+      else if is_in_stmt after b then (
+        let new_stmts =
+          insert_ss ~using:After ~update before after ss b.bstmts
+        in
+        is_patched := true;
+        ChangeTo { b with bstmts = new_stmts })
+      else DoChildren
+  end
+
+class insertStmtVisitor ?(update = false) target_func before after ss =
+  object
+    inherit Cil.nopCilVisitor
+
+    method! vfunc (f : Cil.fundec) =
+      if String.equal f.svar.vname target_func then
+        ChangeTo
+          (Cil.visitCilFunction
+             (new insertStmtFuncVisitor ~update before after ss)
+             f)
+      else DoChildren
+  end
+
+let delete_elt_stmt s stmts =
+  let new_stmts, patched =
+    List.fold_left
+      ~f:(fun (new_stmts, patched) stmt ->
+        if (not patched) && phys_equal stmt s then (new_stmts, true)
+        else (stmt :: new_stmts, patched))
+      ~init:([], false) stmts
+  in
+  (List.rev new_stmts, patched)
+
+class deleteStmtfromBlockVisitor s =
+  object
+    inherit Cil.nopCilVisitor
+
+    method! vblock (b : Cil.block) =
+      let new_bstmts, patched = delete_elt_stmt s b.bstmts in
+      if patched then (
+        is_patched := true;
+        ChangeTo { b with bstmts = new_bstmts })
+      else DoChildren
+  end
+
+class deleteStmtfromFuncVisitor target_func ss =
+  object
+    inherit Cil.nopCilVisitor
+
+    method! vfunc (f : Cil.fundec) =
+      if String.equal f.svar.vname target_func then
+        let vis = new deleteStmtfromBlockVisitor ss in
+        ChangeTo (Cil.visitCilFunction vis f)
+      else SkipChildren
+  end
+
+class replaceExpVisitor from_exp to_exp =
+  object
+    inherit Cil.nopCilVisitor
+
+    method! vexpr e =
+      if Ast.isom_exp from_exp e then (
+        is_patched := true;
+        ChangeTo to_exp)
+      else DoChildren
+  end
+
+class replaceExpinStmt parent from_exp to_exp =
+  object
+    inherit Cil.nopCilVisitor
+
+    method! vstmt s =
+      if phys_equal parent s then
+        let vis = new replaceExpVisitor from_exp to_exp in
+        let new_stmt = Cil.visitCilStmt vis s in
+        if !is_patched then ChangeTo new_stmt
+        else
+          let from_exp =
+            match from_exp with Cil.CastE (_, e) -> e | _ -> from_exp
+          in
+          let vis = new replaceExpVisitor from_exp to_exp in
+          ChangeTo (Cil.visitCilStmt vis s)
+      else DoChildren
+  end
+
+class updateExpVisitor target_func parent from_exp to_exp =
+  object
+    inherit Cil.nopCilVisitor
+
+    method! vfunc (f : Cil.fundec) =
+      if String.equal f.svar.vname target_func then
+        let vis = new replaceExpinStmt parent from_exp to_exp in
+        ChangeTo (Cil.visitCilFunction vis f)
+      else SkipChildren
+  end
+
+class replaceStmt from_stmt to_stmt =
+  object
+    inherit Cil.nopCilVisitor
+
+    method! vstmt s =
+      if phys_equal s from_stmt then ChangeTo to_stmt else DoChildren
+  end
+
+class updateCallExpVisitor target_func from_stmt to_stmt =
+  object
+    inherit Cil.nopCilVisitor
+
+    method! vfunc (f : Cil.fundec) =
+      if String.equal f.svar.vname target_func then
+        let vis = new replaceStmt from_stmt to_stmt in
+        ChangeTo (Cil.visitCilFunction vis f)
+      else SkipChildren
+  end
+
+let apply_insert_stmt ?(update = false) func_name before after ss donee =
+  if update then L.info "Applying UpdateStmt..."
+  else L.info "Applying InsertStmt...";
+  is_patched := false;
+  List.iter ~f:(fun s -> L.info "before:\n%s" (Ast.s_stmt s)) before;
+  let very_before = List.last before in
+  let very_after = List.hd after in
+  if Option.is_none very_before && Option.is_none very_after then
+    L.error "apply_insert_stmt - cannot be patched";
+  let vis = new insertStmtVisitor ~update func_name very_before very_after ss in
+  Cil.visitCilFile vis donee;
+  if not !is_patched then Logger.warn "failed to apply InsertStmt"
+  else L.info "Successfully applied InsertStmt at %s" func_name
+
+let apply_delete_stmt func_name s donee =
+  L.info "Applying DeleteStmt...";
+  is_patched := false;
+  let vis = new deleteStmtfromFuncVisitor func_name s in
+  Cil.visitCilFile vis donee;
+  if not !is_patched then Logger.warn "failed to apply DeleteStmt"
+  else L.info "Successfully applied DeleteStmt at %s" func_name
+
+let apply_update_exp func_name s e1 e2 donee =
+  L.info "Applying UpdateExp...";
+  is_patched := false;
+  let vis = new updateExpVisitor func_name s e1 e2 in
+  Cil.visitCilFile vis donee;
+  if not !is_patched then Logger.warn "failed to apply UpdateExp"
+  else L.info "Successfully applied UpdateExp at %s" func_name
+
+let apply_update_callexp func_name s s2 donee =
+  L.info "Applying UpdateCallExp...";
+  is_patched := false;
+  let vis = new updateCallExpVisitor func_name s s2 in
+  Cil.visitCilFile vis donee;
+  if not !is_patched then Logger.warn "failed to apply UpdateCallExp"
+  else L.info "Successfully applied UpdateCalExp at %s" func_name
+
+let apply_action donee = function
+  | D.InsertStmt (func_name, before, ss, after) ->
+      apply_insert_stmt func_name before after ss donee
+  | D.DeleteStmt (func_name, s) -> apply_delete_stmt func_name s donee
+  | D.UpdateStmt (func_name, before, ss, after) ->
+      apply_insert_stmt ~update:true func_name before after ss donee
+  | D.UpdateExp (func_name, s, e1, e2) ->
+      apply_update_exp func_name s e1 e2 donee
+  | D.UpdateCallExp (func_name, s, s2) ->
+      apply_update_callexp func_name s s2 donee
+  | _ -> L.error "apply_action - Not implemented"
+
+let write_out path ast =
+  let out_chan_orig = Core.Out_channel.create path in
+  Cil.dumpFile Cil.defaultCilPrinter out_chan_orig path ast
+
+let run donee diff =
+  Logger.info "%d actions to apply" (List.length diff);
+  List.iter ~f:(apply_action donee) diff;
+  donee

src/dune

@@ -1,17 +1,14 @@
-(library
- (name patronlib)
- (modules options)
- (wrapped false)
- (libraries cmdliner logger memtrace))
-
 (executable
  (name main)
- (modules :standard \ options)
+ (modules :standard)
  (libraries
-  patronlib
+  cmdliner
+  logger
+  memtrace
   yojson
   core
   core_unix
+  core_unix.filename_unix
   z3
   cil
   cil.all-features

src/editFunction.ml

@@ -1,6 +1,7 @@
 open Core
 module Hashtbl = Stdlib.Hashtbl
 module Set = Stdlib.Set
+module F = Format
 module J = Yojson.Basic.Util
 module D = Diff
 module A = AbsDiff
@@ -241,11 +242,12 @@ let translate_update_callexp maps sol_map s s2 =
   let new_s2 = translate_new_stmt maps sol_map s2.A.ast in
   D.UpdateCallExp (target_func_name, new_s, new_s2)
 
-let translate maps out_dir target_alarm abs_diff =
+let translate cand_donor maps out_dir target_alarm abs_diff =
   Logger.info "Translating patch...";
   let sol_map = Hashtbl.create 1000 in
   Hashtbl.reset sol_map;
-  H.parse_map out_dir (target_alarm ^ "_sol.map") sol_map;
+  let sm_file = F.asprintf "%s_%s_sol.map" cand_donor target_alarm in
+  H.parse_map out_dir sm_file sol_map;
   List.map
     ~f:(fun diff ->
       match diff with