Add option to slice out printing and tracing functions when generating C

Make instruction dependency graph use graph.ml

Expose incremental graph building functions for performance in graph.mli

5 files changed, 84 insertions, 77 deletions

diff --git a/src/bytecode_util.ml b/src/bytecode_util.ml
index 489bcc64..ee407289 100644
--- a/src/bytecode_util.ml
+++ b/src/bytecode_util.ml
@@ -540,6 +540,7 @@ module Node = struct
     | G_id id1, G_id id2 -> Id.compare id1 id2
     | G_label str1, G_label str2 -> String.compare str1 str2
     | G_instr (n1, _), G_instr (n2, _) -> compare n1 n2
+    | G_start  , G_start   -> 0
     | G_start  , _         -> 1
     | _        , G_start   -> -1
     | G_instr _, _         -> 1
@@ -548,10 +549,12 @@ module Node = struct
     | _        , G_id _    -> -1
 end
 
+module NodeGraph = Graph.Make(Node)
+
 module NM = Map.Make(Node)
 module NS = Set.Make(Node)
 
-type dep_graph = NS.t NM.t
+type dep_graph = NodeGraph.graph
 
 let rec fragment_deps = function
   | F_id id | F_ref id -> NS.singleton (G_id id)
@@ -593,78 +596,74 @@ let instr_deps = function
   | I_undefined _ -> NS.empty, NS.empty
   | I_match_failure -> NS.empty, NS.empty
 
-let add_link from_node to_node graph =
-  try
-    NM.add from_node (NS.add to_node (NM.find from_node graph)) graph
-  with
-  | Not_found -> NM.add from_node (NS.singleton to_node) graph
-
-let leaves graph =
-  List.fold_left (fun acc (from_node, to_nodes) -> NS.filter (fun to_node -> Node.compare to_node from_node != 0) (NS.union acc to_nodes))
-                 NS.empty
-                 (NM.bindings graph)
-
-(* Ensure that all leaves exist in the graph *)
-let fix_leaves graph =
-  NS.fold (fun leaf graph -> if NM.mem leaf graph then graph else NM.add leaf NS.empty graph) (leaves graph) graph
-
 let instrs_graph instrs =
   let icounter = ref 0 in
-  let graph = ref NM.empty in
+  let graph = ref NodeGraph.empty in
 
-  let rec add_instr last_instr (I_aux (instr, _) as iaux) =
+  let rec add_instr last_instrs (I_aux (instr, _) as iaux) =
     incr icounter;
     let node = G_instr (!icounter, iaux) in
     match instr with
     | I_block instrs | I_try_block instrs ->
-       List.fold_left add_instr last_instr instrs
+       List.fold_left add_instr last_instrs instrs
     | I_if (_, then_instrs, else_instrs, _) ->
        begin
          let inputs, _ = instr_deps instr in (* if has no outputs *)
-         graph := add_link last_instr node !graph;
-         NS.iter (fun input -> graph := add_link input node !graph) inputs;
-         let n1 = List.fold_left add_instr node then_instrs in
-         let n2 = List.fold_left add_instr node else_instrs in
+         List.iter (fun i -> graph := NodeGraph.add_edge' i node !graph) last_instrs;
+         NS.iter (fun input -> graph := NodeGraph.add_edge' input node !graph) inputs;
+         let n1 = List.fold_left add_instr [node] then_instrs in
+         let n2 = List.fold_left add_instr [node] else_instrs in
          incr icounter;
          let join = G_instr (!icounter, icomment "join") in
-         graph := add_link n1 join !graph;
-         graph := add_link n2 join !graph;
-         join
+         List.iter (fun i -> graph := NodeGraph.add_edge' i join !graph) n1;
+         List.iter (fun i -> graph := NodeGraph.add_edge' i join !graph) n2;
+         [join]
+       end
+    | I_return _ ->
+       begin
+         let inputs, outputs = instr_deps instr in
+         List.iter (fun i -> graph := NodeGraph.add_edge' i node !graph) last_instrs;
+         NS.iter (fun input -> graph := NodeGraph.add_edge' input node !graph) inputs;
+         NS.iter (fun output -> graph := NodeGraph.add_edge' node output !graph) outputs;
+         []
        end
+    | I_label _ ->
+       node :: last_instrs
     | I_goto label ->
        begin
          let _, outputs = instr_deps instr in
-         graph := add_link last_instr node !graph;
-         NS.iter (fun output -> graph := add_link node output !graph) outputs;
-         incr icounter;
-         G_instr (!icounter, icomment "after goto")
+         List.iter (fun i -> graph := NodeGraph.add_edge' i node !graph) last_instrs;
+         NS.iter (fun output -> graph := NodeGraph.add_edge' node output !graph) outputs;
+         []
        end
     | _ ->
        begin
          let inputs, outputs = instr_deps instr in
-         graph := add_link last_instr node !graph;
-         NS.iter (fun input -> graph := add_link input node !graph) inputs;
-         NS.iter (fun output -> graph := add_link node output !graph) outputs;
-         node
+         List.iter (fun i -> graph := NodeGraph.add_edge' i node !graph) last_instrs;
+         NS.iter (fun input -> graph := NodeGraph.add_edge' input node !graph) inputs;
+         NS.iter (fun output -> graph := NodeGraph.add_edge' node output !graph) outputs;
+         [node]
        end
   in
-  ignore (List.fold_left add_instr G_start instrs);
-  fix_leaves !graph
+  ignore (List.fold_left add_instr [G_start] instrs);
+  let graph = NodeGraph.fix_leaves !graph in
+  graph
 
 let make_dot id graph =
   Util.opt_colors := false;
   let to_string node = String.escaped (string_of_node node) in
   let node_color = function
-    | G_start                           -> "lightpink"
-    | G_id _                            -> "yellow"
-    | G_instr (_, I_aux (I_decl _, _))  -> "olivedrab1"
-    | G_instr (_, I_aux (I_init _, _))  -> "springgreen"
-    | G_instr (_, I_aux (I_clear _, _)) -> "peachpuff"
-    | G_instr (_, I_aux (I_goto _, _))  -> "orange1"
-    | G_instr (_, I_aux (I_label _, _)) -> "white"
-    | G_instr (_, I_aux (I_raw _, _))   -> "khaki"
-    | G_instr _                         -> "azure"
-    | G_label _                         -> "lightpink"
+    | G_start                            -> "lightpink"
+    | G_id _                             -> "yellow"
+    | G_instr (_, I_aux (I_decl _, _))   -> "olivedrab1"
+    | G_instr (_, I_aux (I_init _, _))   -> "springgreen"
+    | G_instr (_, I_aux (I_clear _, _))  -> "peachpuff"
+    | G_instr (_, I_aux (I_goto _, _))   -> "orange1"
+    | G_instr (_, I_aux (I_label _, _))  -> "white"
+    | G_instr (_, I_aux (I_raw _, _))    -> "khaki"
+    | G_instr (_, I_aux (I_return _, _)) -> "deeppink"
+    | G_instr _                          -> "azure"
+    | G_label _                          -> "lightpink"
   in
   let edge_color from_node to_node =
     match from_node, to_node with
@@ -677,17 +676,7 @@ let make_dot id graph =
     | _        , _         -> "coral3"
   in
   let out_chan = open_out (Util.zencode_string (string_of_id id) ^ ".gv") in
-  output_string out_chan "digraph DEPS {\n";
-  let make_node from_node =
-    output_string out_chan (Printf.sprintf "  \"%s\" [fillcolor=%s;style=filled];\n" (to_string from_node) (node_color from_node))
-  in
-  let make_line from_node to_node =
-    output_string out_chan (Printf.sprintf "  \"%s\" -> \"%s\" [color=%s];\n" (to_string from_node) (to_string to_node) (edge_color from_node to_node))
-  in
-  NM.bindings graph |> List.iter (fun (from_node, _) -> make_node from_node);
-  NM.bindings graph |> List.iter (fun (from_node, to_nodes) -> NS.iter (make_line from_node) to_nodes);
-  output_string out_chan "}\n";
-  Util.opt_colors := true;
+  NodeGraph.make_dot node_color edge_color to_string out_chan graph;
   close_out out_chan
 
 let rec map_clexp_ctyp f = function
diff --git a/src/constant_fold.ml b/src/constant_fold.ml
index 0ede2401..f85fb673 100644
--- a/src/constant_fold.ml
+++ b/src/constant_fold.ml
@@ -206,10 +206,8 @@ let rec rewrite_constant_function_calls' ast =
 
   let rw_funcall e_aux annot =
     match e_aux with
-      (*
     | E_app (id, args) when fold_to_unit id ->
-       ok (); E_aux (E_lit (L_aux (L_unit, Parse_ast.Unknown)), annot)
-       *)
+       ok (); E_aux (E_lit (L_aux (L_unit, fst annot)), annot)
 
     | E_app (id, args) when List.for_all is_constant args ->
        evaluate e_aux annot
diff --git a/src/graph.ml b/src/graph.ml
index e3af0b97..21863e47 100644
--- a/src/graph.ml
+++ b/src/graph.ml
@@ -69,6 +69,15 @@ module type S =
     val add_edge : node -> node -> graph -> graph
     val add_edges : node -> node list -> graph -> graph
 
+    (** Add edges to the graph, but may leave the internal structure
+       of the graph in a non-normalized state. Fix leaves repairs any
+       such issue in the graph. These additional functions are much
+       faster than those above, but it is important to call fix_leaves
+       before calling reachable, prune, or any other function. *)
+    val add_edge' : node -> node -> graph -> graph
+    val add_edges' : node -> node list -> graph -> graph
+    val fix_leaves : graph -> graph
+
     val children : graph -> node -> node list
 
     (** Return the set of nodes that are reachable from the first set
@@ -119,19 +128,21 @@ module Make(Ord: OrderedType) = struct
   let fix_leaves cg =
     NS.fold (fun leaf cg -> if NM.mem leaf cg then cg else NM.add leaf NS.empty cg) (leaves cg) cg
 
-  (* FIXME: don't use fix_leaves because this is inefficient *)
-  let add_edge caller callee cg =
+  let add_edge' caller callee cg =
     try
-      fix_leaves (NM.add caller (NS.add callee (NM.find caller cg)) cg)
+      NM.add caller (NS.add callee (NM.find caller cg)) cg
     with
-    | Not_found -> fix_leaves (NM.add caller (NS.singleton callee) cg)
+    | Not_found -> NM.add caller (NS.singleton callee) cg
 
-  let add_edges caller callees cg =
+  let add_edges' caller callees cg =
     let callees = List.fold_left (fun s c -> NS.add c s) NS.empty callees in
     try
-      fix_leaves (NM.add caller (NS.union callees (NM.find caller cg)) cg)
+      NM.add caller (NS.union callees (NM.find caller cg)) cg
     with
-    | Not_found -> fix_leaves (NM.add caller callees cg)
+    | Not_found -> NM.add caller callees cg
+
+  let add_edge caller callee cg = fix_leaves (add_edge' caller callee cg)
+  let add_edges caller callees cg = fix_leaves (add_edges' caller callees cg)
 
   let reachable roots cuts cg =
     let visited = ref NS.empty in
diff --git a/src/graph.mli b/src/graph.mli
index 09b78304..02480a9d 100644
--- a/src/graph.mli
+++ b/src/graph.mli
@@ -71,6 +71,15 @@ module type S =
     val add_edge : node -> node -> graph -> graph
     val add_edges : node -> node list -> graph -> graph
 
+    (** Add edges to the graph, but may leave the internal structure
+       of the graph in a non-normalized state. Fix leaves repairs any
+       such issue in the graph. These additional functions are much
+       faster than those above, but it is important to call fix_leaves
+       before calling reachable, prune, or any other function. *)
+    val add_edge' : node -> node -> graph -> graph
+    val add_edges' : node -> node list -> graph -> graph
+    val fix_leaves : graph -> graph
+
     val children : graph -> node -> node list
 
     (** Return the set of nodes that are reachable from the first set
diff --git a/src/slice.ml b/src/slice.ml
index cbf8ee5d..c1829f7d 100644
--- a/src/slice.ml
+++ b/src/slice.ml
@@ -133,18 +133,18 @@ let add_def_to_graph graph def =
     begin match e_aux with
     | E_id id ->
        begin match Env.lookup_id id env with
-       | Register _ -> graph := G.add_edge self (Register id) !graph
+       | Register _ -> graph := G.add_edge' self (Register id) !graph
        | _ ->
           if IdSet.mem id (Env.get_toplevel_lets env) then
-            graph := G.add_edge self (Letbind id) !graph
+            graph := G.add_edge' self (Letbind id) !graph
           else ()
        end
     | E_app (id, _) ->
-       graph := G.add_edge self (Function id) !graph
+       graph := G.add_edge' self (Function id) !graph
     | E_ref id ->
-       graph := G.add_edge self (Register id) !graph
+       graph := G.add_edge' self (Register id) !graph
     | E_cast (typ, _) ->
-       IdSet.iter (fun id -> graph := G.add_edge self (Type id) !graph) (typ_ids typ)
+       IdSet.iter (fun id -> graph := G.add_edge' self (Type id) !graph) (typ_ids typ)
     | _ -> ()
     end;
     E_aux (e_aux, annot)
@@ -160,19 +160,19 @@ let add_def_to_graph graph def =
 
   begin match def with
   | DEF_spec (VS_aux (VS_val_spec (TypSchm_aux (TypSchm_ts (typq, typ), _), id, _, _), _)) ->
-     graph := G.add_edges (Function id) [] !graph;
-     IdSet.iter (fun typ_id -> graph := G.add_edge (Function id) (Type typ_id) !graph) (typ_ids typ)
+     graph := G.add_edges' (Function id) [] !graph;
+     IdSet.iter (fun typ_id -> graph := G.add_edge' (Function id) (Type typ_id) !graph) (typ_ids typ)
   | DEF_fundef fdef ->
      let id = id_of_fundef fdef in
-     graph := G.add_edges (Function id) [] !graph;
+     graph := G.add_edges' (Function id) [] !graph;
      ignore (rewrite_fun (rewriters (Function id)) fdef)
   | DEF_val (LB_aux (LB_val (pat, exp), _) as lb) ->
      let ids = pat_ids pat in
-     IdSet.iter (fun id -> graph := G.add_edges (Letbind id) [] !graph) ids;
+     IdSet.iter (fun id -> graph := G.add_edges' (Letbind id) [] !graph) ids;
      IdSet.iter (fun id -> ignore (rewrite_let (rewriters (Letbind id)) lb)) ids
   | _ -> ()
   end;
-  !graph
+  G.fix_leaves !graph
 
 let rec graph_of_ast (Defs defs) =
   let module G = Graph.Make(Node) in