Output g2html directly

.gitignore

@@ -23,6 +23,7 @@ doclist.odocl
 autom4te.cache
 mytests
 result/*
+result2/*
 pml-result/*
 tests/regression/*/goblint_temp
 linux-headers

src/common/framework/cfgTools.ml

@@ -657,12 +657,12 @@ let sprint_fundec_html_dot (module Cfg : CfgBidir) live fd =
   fprint_fundec_html_dot (module Cfg) live fd Format.str_formatter;
   Format.flush_str_formatter ()
 
-let dead_code_cfg (module FileCfg: MyCFG.FileCfg) live =
+let dead_code_cfg ~path (module FileCfg: MyCFG.FileCfg) live =
   iterGlobals FileCfg.file (fun glob ->
       match glob with
       | GFun (fd,loc) ->
         (* ignore (Printf.printf "fun: %s\n" fd.svar.vname); *)
-        let base_dir = GobSys.mkdir_or_exists_absolute (Fpath.v "cfgs") in
+        let base_dir = GobSys.mkdir_or_exists_absolute path in
         let c_file_name = Str.global_substitute (Str.regexp Filename.dir_sep) (fun _ -> "%2F") loc.file in
         let dot_file_name = fd.svar.vname^".dot" in
         let file_dir = GobSys.mkdir_or_exists_absolute Fpath.(base_dir / c_file_name) in

src/config/options.schema.json

@@ -81,7 +81,7 @@
       "description":
         "Result style: none, fast_xml, json, pretty, pretty-deterministic, json-messages, sarif.",
       "type": "string",
-      "enum": ["none", "fast_xml", "json", "pretty", "pretty-deterministic", "json-messages", "sarif"],
+      "enum": ["none", "fast_xml", "g2html", "json", "pretty", "pretty-deterministic", "json-messages", "sarif"],
       "default": "none"
     },
     "solver": {

src/framework/analysisResult.ml

@@ -59,15 +59,16 @@ struct
 
   include C
 
+
+  let printXml_print_one f n v =
+    (* Not using Node.location here to have updated locations in incremental analysis.
+        See: https://github.com/goblint/analyzer/issues/290#issuecomment-881258091. *)
+    let loc = UpdateCil.getLoc n in
+    BatPrintf.fprintf f "<call id=\"%s\" file=\"%s\" line=\"%d\" order=\"%d\" column=\"%d\" endLine=\"%d\" endColumn=\"%d\" synthetic=\"%B\">\n" (Node.show_id n) loc.file loc.line loc.byte loc.column loc.endLine loc.endColumn loc.synthetic;
+    BatPrintf.fprintf f "%a</call>\n" Range.printXml v
+
   let printXml f xs =
-    let print_one n v =
-      (* Not using Node.location here to have updated locations in incremental analysis.
-         See: https://github.com/goblint/analyzer/issues/290#issuecomment-881258091. *)
-      let loc = UpdateCil.getLoc n in
-      BatPrintf.fprintf f "<call id=\"%s\" file=\"%s\" line=\"%d\" order=\"%d\" column=\"%d\" endLine=\"%d\" endColumn=\"%d\" synthetic=\"%B\">\n" (Node.show_id n) loc.file loc.line loc.byte loc.column loc.endLine loc.endColumn loc.synthetic;
-      BatPrintf.fprintf f "%a</call>\n" Range.printXml v
-    in
-    iter print_one xs
+    iter (printXml_print_one f) xs
 
   let printJson f xs =
     let print_one n v =
@@ -78,28 +79,30 @@ struct
     in
     iter print_one xs
 
+  let printXmlWarning_one_text f Messages.Piece.{loc; text = m; _} =
+    match loc with
+    | Some loc ->
+      let l = Messages.Location.to_cil loc in
+      BatPrintf.fprintf f "\n<text file=\"%s\" line=\"%d\" column=\"%d\">%s</text>" l.file l.line l.column (XmlUtil.escape m)
+    | None ->
+      () (* TODO: not outputting warning without location *)
+
+  let printXmlWarning_one_w f (m: Messages.Message.t) = match m.multipiece with
+    | Single piece  -> printXmlWarning_one_text f piece
+    | Group {group_text = n; pieces = e; group_loc} ->
+      let group_loc_text = match group_loc with
+        | None -> ""
+        | Some group_loc -> GobPretty.sprintf " (%a)" CilType.Location.pretty (Messages.Location.to_cil group_loc)
+      in
+      BatPrintf.fprintf f "<group name=\"%s%s\">%a</group>\n" n group_loc_text (BatList.print ~first:"" ~last:"" ~sep:"" printXmlWarning_one_text) e
+
+  let printXmlWarning_one_w f x = BatPrintf.fprintf f "\n<warning>%a</warning>" printXmlWarning_one_w x
+
   let printXmlWarning f () =
-    let one_text f Messages.Piece.{loc; text = m; _} =
-      match loc with
-      | Some loc ->
-        let l = Messages.Location.to_cil loc in
-        BatPrintf.fprintf f "\n<text file=\"%s\" line=\"%d\" column=\"%d\">%s</text>" l.file l.line l.column (XmlUtil.escape m)
-      | None ->
-        () (* TODO: not outputting warning without location *)
-    in
-    let one_w f (m: Messages.Message.t) = match m.multipiece with
-      | Single piece  -> one_text f piece
-      | Group {group_text = n; pieces = e; group_loc} ->
-        let group_loc_text = match group_loc with
-          | None -> ""
-          | Some group_loc -> GobPretty.sprintf " (%a)" CilType.Location.pretty (Messages.Location.to_cil group_loc)
-        in
-        BatPrintf.fprintf f "<group name=\"%s%s\">%a</group>\n" n group_loc_text (BatList.print ~first:"" ~last:"" ~sep:"" one_text) e
-    in
-    let one_w f x = BatPrintf.fprintf f "\n<warning>%a</warning>" one_w x in
-    List.iter (one_w f) !Messages.Table.messages_list
+    List.iter (printXmlWarning_one_w f) !Messages.Table.messages_list
 
-  let output table gtable gtfxml (file: file) =
+  let output table live gtable gtfxml (module FileCfg: MyCFG.FileCfg) =
+    let file = FileCfg.file in
     let out = Messages.get_out result_name !Messages.out in
     match get_string "result" with
     | "pretty" -> ignore (fprintf out "%a\n" pretty (Lazy.force table))
@@ -146,6 +149,165 @@ struct
       else
         let f = BatIO.output_channel out in
         write_file f (get_string "outfile")
+    | "g2html" ->
+      (* copied from above *)
+      let module SH = BatHashtbl.Make (Basetype.RawStrings) in
+      let module IH = BatHashtbl.Make (struct type t = int [@@deriving hash, eq] end) in
+      let file2funs = SH.create 100 in
+      let funs2node = SH.create 100 in
+      iter (fun n _ -> SH.add funs2node (Node.find_fundec n).svar.vname n) (Lazy.force table);
+      iterGlobals file (function
+          | GFun (fd,loc) -> SH.add file2funs loc.file fd.svar.vname
+          | _ -> ()
+        );
+      let p_node f n = BatPrintf.fprintf f "%s" (Node.show_id n) in
+      let p_nodes f xs =
+        List.iter (BatPrintf.fprintf f "<node name=\"%a\"/>\n" p_node) xs
+      in
+      let p_funs f xs =
+        let one_fun n =
+          BatPrintf.fprintf f "<function name=\"%s\">\n%a</function>\n" n p_nodes (SH.find_all funs2node n)
+        in
+        List.iter one_fun xs
+      in
+      GobSys.mkdir_or_exists Fpath.(v "result2");
+      GobSys.mkdir_or_exists Fpath.(v "result2" / "nodes");
+      GobSys.mkdir_or_exists Fpath.(v "result2" / "warn");
+      GobSys.mkdir_or_exists Fpath.(v "result2" / "files");
+      BatFile.with_file_out "result2/index.xml" (fun f ->
+          BatPrintf.fprintf f {xml|<?xml version="1.0" ?>
+<?xml-stylesheet type="text/xsl" href="report.xsl"?>
+<report>|xml};
+          (* TODO: exclude <file> path? *)
+          (* TODO: exclude <node>s? *)
+          (* TODO: exclude dead files/functions? *)
+          (* BatEnum.iter (fun b -> BatPrintf.fprintf f "<file name=\"%s\" path=\"%s\">\n%a</file>\n" (Filename.basename b) b p_funs (SH.find_all file2funs b)) (BatEnum.uniq @@ SH.keys file2funs); *)
+          (* g2html has full path in name field *)
+          BatEnum.iter (fun b -> BatPrintf.fprintf f "<file name=\"%s\">\n%a</file>\n" b p_funs (SH.find_all file2funs b)) (BatEnum.uniq @@ SH.keys file2funs);
+          BatPrintf.fprintf f "</report>";
+        );
+      BatFile.with_file_out "result2/nodes/globals.xml" (fun f ->
+          BatPrintf.fprintf f {xml|<?xml version="1.0" ?>
+<?xml-stylesheet type="text/xsl" href="../globals.xsl"?>
+<globs>|xml};
+          gtfxml f gtable;
+          BatPrintf.fprintf f "</globs>";
+        );
+      let file2line2nodes: Node.t IH.t SH.t = SH.create 10 in
+      iter (fun n v ->
+          BatFile.with_file_out (Printf.sprintf "result2/nodes/%s.xml" (Node.show_id n)) (fun f ->
+              BatPrintf.fprintf f {xml|<?xml version="1.0" ?>
+<?xml-stylesheet type="text/xsl" href="../node.xsl"?>
+<loc>|xml};
+              (* TODO: need fun in <call>? *)
+              printXml_print_one f n v;
+              BatPrintf.fprintf f "</loc>";
+            );
+          let loc = UpdateCil.getLoc n in (* from printXml_print_one *)
+          let line2nodes: Node.t IH.t =
+            match SH.find_option file2line2nodes loc.file with
+            | Some line2nodes -> line2nodes
+            | None ->
+              let line2nodes = IH.create 100 in
+              SH.replace file2line2nodes loc.file line2nodes;
+              line2nodes
+          in
+          IH.add line2nodes loc.line n
+        ) (Lazy.force table);
+      let file2line2warns: int IH.t SH.t = SH.create 10 in
+      List.iteri (fun i w ->
+          BatFile.with_file_out (Printf.sprintf "result2/warn/warn%d.xml" (i + 1)) (fun f ->
+              BatPrintf.fprintf f {xml|<?xml version="1.0" ?>
+<?xml-stylesheet type="text/xsl" href="../warn.xsl"?>|xml};
+              printXmlWarning_one_w f w;
+            );
+          let locs =
+            match w.multipiece with
+            | Single piece -> [piece.loc]
+            | Group {pieces; _} -> List.map (fun p -> p.Messages.Piece.loc) pieces (* TODO: add group_loc, old doesn't *)
+          in
+          List.iter (fun (loc: Messages.Location.t) ->
+              let loc = Messages.Location.to_cil loc in
+              let line2warns: int IH.t =
+                match SH.find_option file2line2warns loc.file with
+                | Some line2warns -> line2warns
+                | None ->
+                  let line2warns = IH.create 100 in
+                  SH.replace file2line2warns loc.file line2warns;
+                  line2warns
+              in
+              IH.add line2warns loc.line (i + 1)
+            ) (List.filter_map Fun.id locs)
+        ) !Messages.Table.messages_list;
+      BatEnum.iter (fun b ->
+          let c_file_name = Str.global_substitute (Str.regexp Filename.dir_sep) (fun _ -> "%2F") b in
+          BatFile.with_file_out (Printf.sprintf "result2/files/%s.xml" c_file_name) (fun f ->
+              BatPrintf.fprintf f {xml|<?xml version="1.0" ?>
+<?xml-stylesheet type="text/xsl" href="../file.xsl"?>
+<file>
+|xml};
+              let lines = BatFile.lines_of b in
+              BatEnum.iteri (fun line text ->
+                  let nodes =
+                    match SH.find_option file2line2nodes b with
+                    | Some line2nodes -> IH.find_all line2nodes (line + 1) |> BatList.unique ~eq:Node.equal
+                    | None -> []
+                  in
+                  let print_node f w =
+                    BatPrintf.fprintf f "&quot;%s&quot;" (Node.show_id w)
+                  in
+                  let warns =
+                    match SH.find_option file2line2warns b with
+                    | Some line2warns -> IH.find_all line2warns (line + 1) |> BatList.unique
+                    | None -> []
+                  in
+                  let print_warn f w =
+                    BatPrintf.fprintf f "&quot;warn%d&quot;" w
+                  in
+                  let dead = nodes <> [] && not (List.exists live nodes) in
+                  BatPrintf.fprintf f {xml|<ln nr="%d" ns="[%a]" wrn="[%a]" ded="%B">%s</ln>
+|xml} (line + 1) (BatList.print ~first:"" ~sep:"," ~last:"" print_node) nodes (BatList.print ~first:"" ~sep:"," ~last:"" print_warn) warns dead (XmlUtil.escape text)
+                ) lines;
+              BatPrintf.fprintf f "</file>";
+            )
+        ) (BatEnum.uniq @@ SH.keys file2funs);
+      (* CfgTools.dead_code_cfg ~path:Fpath.(v "result2" / "dot") (module FileCfg) live; *)
+      (* TODO: copied and modified... *)
+      let tasks = foldGlobals FileCfg.file (fun acc glob ->
+          match glob with
+          | GFun (fd,loc) ->
+            (* ignore (Printf.printf "fun: %s\n" fd.svar.vname); *)
+            let base_dir = GobSys.mkdir_or_exists_absolute Fpath.(v "result2" / "dot") in
+            let base_dir2 = GobSys.mkdir_or_exists_absolute Fpath.(v "result2" / "cfgs") in
+            let c_file_name = Str.global_substitute (Str.regexp Filename.dir_sep) (fun _ -> "%2F") loc.file in
+            let dot_file_name = fd.svar.vname^".dot" in
+            let svg_file_name = fd.svar.vname^".svg" in
+            let file_dir = GobSys.mkdir_or_exists_absolute Fpath.(base_dir / c_file_name) in
+            let file_dir2 = GobSys.mkdir_or_exists_absolute Fpath.(base_dir2 / c_file_name) in
+            let fname = Fpath.(file_dir / dot_file_name) in
+            let fname2 = Fpath.(file_dir2 / svg_file_name) in
+            let out = open_out (Fpath.to_string fname) in
+            let ppf = Format.formatter_of_out_channel out in
+            CfgTools.fprint_fundec_html_dot (module FileCfg.Cfg) live fd ppf;
+            Format.pp_print_flush ppf ();
+            close_out out;
+            let task: ProcessPool.task = {
+              command = Filename.quote_command "dot" [Fpath.to_string fname; "-Tsvg"; "-o"; Fpath.to_string fname2];
+              cwd = None;
+            } in
+            task :: acc
+          | _ -> acc
+        ) []
+      in
+      Timing.wrap "graphviz" (ProcessPool.run ~jobs:(GobConfig.jobs ())) tasks;
+      (* TODO: vendor resources *)
+      begin
+        Sys.readdir "g2html/resources"
+        |> Array.to_list
+        |> List.map (fun f -> "g2html/resources/" ^ f)
+        |> (fun fs -> FileUtil.cp fs "result2")
+      end;
+      assert false
     | "json" ->
       let open BatPrintf in
       let module SH = BatHashtbl.Make (Basetype.RawStrings) in

src/framework/control.ml

@@ -754,7 +754,7 @@ struct
     in
 
     if get_bool "exp.cfgdot" then
-      CfgTools.dead_code_cfg (module FileCfg) liveness;
+      CfgTools.dead_code_cfg ~path:(Fpath.v "cfgs") (module FileCfg) liveness;
 
     let warn_global g v =
       (* Logs.debug "warn_global %a %a" EQSys.GVar.pretty_trace g EQSys.G.pretty v; *)
@@ -830,7 +830,7 @@ struct
     if get_string "result" <> "none" then Logs.debug "Generating output: %s" (get_string "result");
 
     Messages.finalize ();
-    Timing.wrap "result output" (Result.output (lazy local_xml) gh make_global_fast_xml) file
+    Timing.wrap "result output" (Result.output (lazy local_xml) liveness gh make_global_fast_xml) (module FileCfg)
 end
 
 (* This function was originally a part of the [AnalyzeCFG] module, but