BSc thesis "Coloring Data Race Interference Graphs"

dune-project

@@ -39,6 +39,7 @@ Goblint includes analyses for assertions, overflows, deadlocks, etc and can be e
     (ocaml (>= 4.14))
     (goblint-cil (>= 2.0.9)) ; TODO no way to define as pin-depends? Used goblint.opam.template to add it for now. https://github.com/ocaml/dune/issues/3231. Alternatively, removing this line and adding cil as a git submodule and `(vendored_dirs cil)` as ./dune also works. This way, no more need to reinstall the pinned cil opam package on changes. However, then cil is cleaned and has to be rebuild together with goblint.
     (batteries (>= 3.9.0))
+    ocamlgraph
     (zarith (>= 1.12))
     (yojson (and (>= 2.0.0) (< 3))) ; json-data-encoding has incompatible yojson representation for yojson 3
     (qcheck-core (>= 0.19))

goblint.opam

@@ -41,6 +41,7 @@ depends: [
   "ocaml" {>= "4.14"}
   "goblint-cil" {>= "2.0.9"}
   "batteries" {>= "3.9.0"}
+  "ocamlgraph"
   "zarith" {>= "1.12"}
   "yojson" {>= "2.0.0" & < "3"}
   "qcheck-core" {>= "0.19"}

src/analyses/raceAnalysis.ml

@@ -391,6 +391,9 @@ struct
         (Pretty.dprintf "total memory locations: %d" total, None);
       ];
     )
+    else
+      ();
+    ()
 end
 
 let _ =

src/config/options.schema.json

@@ -2456,6 +2456,13 @@
           "type": "integer",
           "default": 0
         },
+        "race-coloring": {
+          "title": "warn.race-coloring",
+          "description": "Group race warnings by graph coloring (none, greedy, dsatur, rlf, optimal).",
+          "type": "string",
+          "enum": ["none", "greedy", "dsatur", "rlf", "optimal"],
+          "default": "none"
+        },
         "deterministic": {
           "title": "warn.deterministic",
           "description": "Output messages in deterministic order. Useful for cram testing.",

src/domains/access.ml

@@ -152,7 +152,8 @@ let init (f:file) =
 
 let reset () =
   TSH.clear typeVar;
-  TSH.clear typeIncl
+  TSH.clear typeIncl;
+  ()
 
 type acc_typ = [ `Type of CilType.Typ.t | `Struct of CilType.Compinfo.t * Offset.Unit.t ] [@@deriving eq, ord, hash]
 (** Old access type inferred from an expression. *)
@@ -484,6 +485,55 @@ struct
       AS.pretty w.node AS.pretty w.prefix AS.pretty w.type_suffix AS.pretty w.type_suffix_prefix
 end
 
+module InterferenceGraph = struct
+  module Vertex = struct
+    type t = A.t
+
+    let compare = A.compare
+    let hash = A.hash
+    let equal = A.equal
+  end
+
+  module G = Graph.Imperative.Graph.Concrete (Vertex)
+
+  type t = G.t
+
+  let of_warn_accs (warn_accs : WarnAccs.t) =
+    let graph = G.create () in
+    let all = WarnAccs.union_all warn_accs in
+    AS.iter (fun acc -> G.add_vertex graph acc) all;
+    let accs = AS.elements all in
+    let rec loop = function
+      | [] -> ()
+      | a :: rest ->
+        List.iter (fun b ->
+            if may_race a b then
+              G.add_edge graph a b
+          ) rest;
+        loop rest
+    in
+    loop accs;
+    graph
+
+  module Coloring = AccessColoring.Make (G)
+
+  let of_accesses (accs : AS.t) =
+    let graph = G.create () in
+    AS.iter (fun acc -> G.add_vertex graph acc) accs;
+    let accs_list = AS.elements accs in
+    let rec loop = function
+      | [] -> ()
+      | a :: rest ->
+        List.iter (fun b ->
+            if may_race a b then
+              G.add_edge graph a b
+          ) rest;
+        loop rest
+    in
+    loop accs_list;
+    graph
+end
+
 let group_may_race (warn_accs:WarnAccs.t) =
   if M.tracing then M.tracei "access" "group_may_race %a" WarnAccs.pretty warn_accs;
   (* BFS to traverse one component with may_race edges *)
@@ -594,16 +644,54 @@ let incr_summary ~safe ~vulnerable ~unsafe grouped_accs =
   | Some n when n >= 100 -> is_all_safe := false; incr unsafe
   | Some n -> is_all_safe := false; incr vulnerable
 
-let print_accesses memo grouped_accs =
+let print_accesses ?coloring_mode memo grouped_accs =
   let allglobs = get_bool "allglobs" in
   let race_threshold = get_int "warn.race-threshold" in
-  let msgs race_accs =
+  let coloring_for accs =
+    match coloring_mode with
+    | None -> None
+    | Some "greedy" ->
+      let graph = InterferenceGraph.of_accesses accs in
+      Some (InterferenceGraph.Coloring.color_with (module InterferenceGraph.Coloring.Greedy) graph)
+    | Some "dsatur" ->
+      let graph = InterferenceGraph.of_accesses accs in
+      Some (InterferenceGraph.Coloring.color_with (module InterferenceGraph.Coloring.Dsatur) graph)
+    | Some "rlf" ->
+      let graph = InterferenceGraph.of_accesses accs in
+      Some (InterferenceGraph.Coloring.color_with (module InterferenceGraph.Coloring.Rlf) graph)
+    | Some "optimal" ->
+      let graph = InterferenceGraph.of_accesses accs in
+      Some (InterferenceGraph.Coloring.color_with (module InterferenceGraph.Coloring.Optimal) graph)
+    | Some _ -> None
+  in
+  let msgs ?coloring race_accs =
     let h A.{conf; kind; node; exp; acc} =
       let doc = dprintf "%a with %a (conf. %d)  (exp: %a)" AccessKind.pretty kind MCPAccess.A.pretty acc conf d_exp exp in
       (doc, Some (Messages.Location.Node node))
     in
-    AS.elements race_accs
-    |> List.map h
+    match coloring with
+    | None ->
+      AS.elements race_accs
+      |> List.map h
+    | Some coloring ->
+      let module IntMap = Map.Make (Int) in
+      let module C = InterferenceGraph.Coloring in
+      let add_to_map acc map =
+        match C.color_of coloring acc with
+        | None -> map
+        | Some c ->
+          IntMap.update c (function
+              | None -> Some [acc]
+              | Some accs -> Some (acc :: accs)
+            ) map
+      in
+      let color_map = AS.fold add_to_map race_accs IntMap.empty in
+      IntMap.bindings color_map
+      |> List.concat_map (fun (color, accs) ->
+          let header = (dprintf "Color %d" color, None) in
+          let acc_msgs = accs |> List.rev |> List.map h in
+          header :: acc_msgs
+        )
   in
   let group_loc = match memo with
     | (`Var v, _) -> Some (M.Location.CilLocation v.vdecl) (* TODO: offset location *)
@@ -621,7 +709,8 @@ let print_accesses memo grouped_accs =
           else
             Info
         in
-        M.msg_group severity ?loc:group_loc ~category:Race "Memory location %a (race with conf. %d)" Memo.pretty memo conf (msgs accs);
+        let coloring = coloring_for accs in
+        M.msg_group severity ?loc:group_loc ~category:Race "Memory location %a (race with conf. %d)" Memo.pretty memo conf (msgs ?coloring accs);
         safe_accs
     ) (AS.empty ())
   |> (fun safe_accs ->
@@ -630,6 +719,12 @@ let print_accesses memo grouped_accs =
     )
 
 let warn_global ~safe ~vulnerable ~unsafe warn_accs memo =
+  let coloring_mode =
+    match get_string "warn.race-coloring" with
+    | "" | "none" -> None
+    | "greedy" | "dsatur" | "rlf" | "optimal" as mode -> Some mode
+    | _ -> None
+  in
   let grouped_accs = group_may_race warn_accs in (* do expensive component finding only once *)
   incr_summary ~safe ~vulnerable ~unsafe grouped_accs;
-  print_accesses memo grouped_accs
+  print_accesses ?coloring_mode memo grouped_accs