Commits

Matthew Hammer committed 292e24b

more info in graph output; tried an experiment where I track stackedness that partially worked; i have a new idea to try next

Comments (0)

Files changed (4)

Source/AdaptonUtil/AKList.ml

       end
 
     let memo_filter (type a) (type b) ( filter_f : data -> Key.t -> bool ) =
-      memo_keyed (module L) ~symbol:"map_with_key" begin
+      memo_keyed (module L) ~symbol:"filter" begin
         fun filter xs -> match L.force xs with
           | `Nil -> `Nil
           | `Cons (x, k, xs) ->
     let memo_reduce contract_f ?bias:(b=2) =
       (* contract is hoisted so as to fix its memo table in this body's closure *)
       let contract = memo_contract contract_f ~bias:b in
-      AData.memo_keyed2 (module L) (module Key) ~symbol:"memo_reduce" begin
+      AData.memo_keyed2 (module L) (module Key) ~symbol:"reduce" begin
         fun reduce xs iteration_key ->
           match force xs with
           | `Nil -> failwith "memo_reduce: empty list"

Source/AdaptonZoo/Adapton.ml

     (* should be sufficient for traversing the DCG and creating a picture of it as a graph. *)
     (* XXX TODO: some fields, such as mut_tgts, are not yet maintained by this module. *)
     type debug = {
-      id        : int ;
-      symbol    : Symbol.t option ;
-      key       : Key.t option ;
-      mutable val_string : unit -> string ;
-      mutable is_filthy  : unit -> bool ;
-      mutable mut_tgts   : debug list ;
-      mutable force_tgts : (debug * (unit -> bool)) list ;
+      id          : int ;
+      symbol      : Symbol.t option ;
+      key         : Key.t option ;
+      mutable check_seqno  : int ; (* when we last checked the node's value. *)
+      mutable repair_seqno : int ; (* when we last visited the node for repair. *)
+      mutable arg_string   : unit -> string ;
+      mutable val_string   : unit -> string ;
+      mutable is_filthy    : unit -> bool ;
+      mutable is_stacked   : unit -> bool ;
+      mutable mut_tgts     : debug list ;
+      mutable force_tgts   : (debug * (unit -> bool)) list ;
     }
     ELSE
     type debug = unit
             mut_in  : Mut_edges.t ;
             mut_out : Mut_edges.t ; (* TODO -- DEBUG ONLY. *)
             dependents : Dependents.t;
-            mutable filthy : bool ;    (* Flag used between 'memo_keyed' and 'repair' *)
+            mutable filthy  : bool ; (* Flag used between 'memo_keyed' and 'repair' *)
+            mutable stacked : bool ; (* Flag used to prevent over-dirtying XXX (not sure yet). *)
             debug : debug ; (* 0 words when ADAPTON_LOG=false *)
         }
         and 'a state =
            mut_tgts=[];
            force_tgts=[];
            is_filthy=(fun _ -> failwith "is_filthy");
+           is_stacked=(fun _ -> failwith "is_stacked");
+           arg_string=(fun _ -> "?");
            val_string=(fun _ -> "?");
+           check_seqno=(-1);
+           repair_seqno=(-1);
          }
          ELSE () END)
 
         id=id;
         dependents=Dependents.create 0;
         filthy=false;
+        stacked=false;
         debug=make_debug id None None;
       } in
       IFDEF ADAPTON_LOG THEN meta.debug.is_filthy <- (fun _ -> meta.filthy) END ;
+      IFDEF ADAPTON_LOG THEN meta.debug.is_stacked <- (fun _ -> meta.stacked) END ;
       meta
     (**/**)
 
         id=id;
         dependents=Dependents.create 0;
         filthy=false;
+        stacked=false;
         debug=make_debug id key sym;
       } in
       IFDEF ADAPTON_LOG THEN meta.debug.is_filthy <- (fun _ -> meta.filthy) END ;
+      IFDEF ADAPTON_LOG THEN meta.debug.is_stacked <- (fun _ -> meta.stacked) END ;
       meta
     (**/**)
 
     (**/**) (* helper function to dirty a thunk *)
     let dirty (meta:meta) = Log.log `Dirty begin fun _ ->
-      IFDEF ADAPTON_LOG THEN (
-        Log.more (Printf.sprintf "dirty &%d:" meta.id) ;
-      ) END ;
-      let rec dirty = function
-        | d::ds ->
-            dirty begin Dependents.fold begin fun d ds ->
-              if d.dirty then
-                ds
-              else begin
-                IFDEF ADAPTON_LOG THEN (
-                  Log.more (Printf.sprintf "(&%d,⚑,&%d)" d.dependent.id d.dependee.id);
-                ) END ;
-                incr Statistics.Counts.dirty;
-                d.dirty <- true;
-                IFDEF ADAPTON_LOG THEN Log.usr_hooks.Log.output_graph () END ;
-                d.dependent.dependents::ds
-              end
-            end d ds end
-        | [] ->
-            ()
-      in
-      dirty [ meta.dependents ] ;
+      if meta.stacked then
+        ()
+      else (
+        IFDEF ADAPTON_LOG THEN (
+          Log.more (Printf.sprintf "dirty &%d:" meta.id) ;
+        ) END ;
+        let rec dirty = function
+          | d::ds ->
+              dirty begin Dependents.fold begin fun d ds ->
+                if d.dependee.stacked || d.dirty then
+                  ds
+                else begin
+                  IFDEF ADAPTON_LOG THEN (
+                    Log.more (Printf.sprintf "(&%d,⚑,&%d)" d.dependent.id d.dependee.id);
+                  ) END ;
+                  incr Statistics.Counts.dirty;
+                  d.dirty <- true;
+                  IFDEF ADAPTON_LOG THEN Log.usr_hooks.Log.output_graph () END ;
+                  d.dependent.dependents::ds
+                end
+              end d ds end
+          | [] ->
+              ()
+        in
+        dirty [ meta.dependents ] ;
+      )
     end
       (**/**)
 
     let mark_filthy (meta:meta) =
-      Log.more (Printf.sprintf "filthy &%d." meta.id) ;
-      if not meta.filthy then begin
-        meta.filthy <- true ;
-        (IFDEF ADAPTON_LOG THEN Log.usr_hooks.Log.output_graph () END) ;
-        dirty meta
-      end
+      if meta.stacked then
+        ()
+      else (
+        Log.more (Printf.sprintf "filthy &%d." meta.id) ;
+        if not meta.filthy then begin
+          meta.filthy <- true ;
+          (IFDEF ADAPTON_LOG THEN Log.usr_hooks.Log.output_graph () END) ;
+          dirty meta
+        end
+      )
 
     (**/**) (* helper function to make a receipt check *)
-    let make_check m x k = match m.state with
+    let make_check thunk x k = match thunk.state with
         | Value ( repair, _, _, _, _ ) ->
             repair.repair
-              (fun ( value, _ ) -> k (R.equal value x))
+              (fun ( value, _ ) ->
+                 (IFDEF ADAPTON_LOG THEN
+                    if thunk.meta.debug.check_seqno <> !global_seqno then (
+                      thunk.meta.debug.check_seqno <- !global_seqno ;
+                      Log.usr_hooks.Log.output_graph ()
+                    ) END) ;
+                 k (R.equal value x))
 
         | Thunk _ -> k false
         | Mutable ( value, _ ) -> k (R.equal value x)
         let rec check : 'a . (bool -> 'a) -> 'a = fun k -> make_check m x k
         and m = { meta=make_meta (); state=Mutable ( x, { check } ) } in
         IFDEF ADAPTON_LOG THEN(
+          m.meta.debug.arg_string <- (fun _ -> "");
           m.meta.debug.val_string <- begin fun _ ->
             match m.state with
               | Mutable (v,_) -> R.string v
       let dependencies = ref [] in (* No dependencies, initially. *)
       let mutations = ref [] in (* No mutations, initially. *)
       lazy_stack := ( thunk.meta, dependencies, mutations )::!lazy_stack;
+      thunk.meta.stacked <- true ;
       let value = try
         f ()
       with exn ->
         lazy_stack := List.tl !lazy_stack;
+        thunk.meta.stacked <- false ;
         raise exn
       in
       IFDEF ADAPTON_LOG THEN (
+        Log.usr_hooks.Log.output_graph () ;
         Log.log `EvalRet (fun _ -> Log.more (R.string value) ) ;
       ) END ;
       lazy_stack := List.tl !lazy_stack;
+      thunk.meta.stacked <- false ;
       let thunk_dependencies = List.rev !dependencies in
       let _ = IFDEF ADAPTON_LOG THEN (
         let force_tgts : (debug * (unit -> bool)) list =
       in
       (* repair/receipt performs a truncated inorder traversal of the dependency graph *)
       let repair cont =
+        IFDEF ADAPTON_LOG THEN (
+          if thunk.meta.debug.repair_seqno <> !global_seqno then (
+            thunk.meta.debug.repair_seqno <- !global_seqno ;
+            Log.usr_hooks.Log.output_graph () ;
+          )
+        ) END ;
         match thunk.state with
           | Value ( _, value, receipt, dependencies, evaluate )->
               let rec repair_deps = function
                     incr Statistics.Counts.create;
                     incr Statistics.Counts.miss;
                     IFDEF ADAPTON_LOG THEN (
+                      m.meta.debug.arg_string <- (fun _ -> "?" (* TODO -- need: A.string*));
                       m.meta.debug.val_string <- begin fun _ ->
                         match m.state with
                           | Value (_,v,_,_,_) -> R.string v
         )
         with
 	  | Some row -> begin
-               ( assert_no_memo_keyed_bug symbol key cur_arg row ) ;
+              ( assert_no_memo_keyed_bug symbol key cur_arg row ) ;
               row.Row.seqno  <- !global_seqno ;    (* DEBUG only *)
               row.Row.caller <- current_caller () ; (* DEBUG only *)
               IFDEF ADAPTON_LOG THEN (
                 Log.more (Printf.sprintf "Fresh &%d." thunk.meta.id) ;
               ) END ;
               IFDEF ADAPTON_LOG THEN (
+                thunk.meta.debug.arg_string <- (fun _ -> A.string row.Row.arg);
                 thunk.meta.debug.val_string <- begin fun _ ->
                   match thunk.state with
                     | Value (_,v,_,_,_) -> R.string v
     let output_graph = let graph_seqno = ref 0 in
     fun ?(filename="") (thunk:'a thunk) -> IFDEF ADAPTON_LOG THEN(
       let module Colors = struct
-        let blue = "cornflowerblue"
-        let red  = "red"
-        let grey = "grey"
+        (* http://www.graphviz.org/doc/info/colors.html *)
+        let blue   = "lavender" (*"lightblue"*) (*"cornflowerblue"*)
+        let green  = "palegreen"
+        let red    = "lightpink" (*"red"*)
+        let grey   = "grey"
+        let purple = "mediumorchid1"
       end
       in
       let module S = Set.Make(
         if S.mem node visited then visited
         else (
           let visited = S.add node visited in
-          Printf.fprintf out "  n%d [label=\"%d %s\\n%s\\n%s\" color=%s];\n" node.id node.id
+          Printf.fprintf out "  n%d [label=\"%d %s\\n%s %s\\n%s\" color=%s];\n"
+            node.id node.id
             (match node.key with None -> "" | Some k -> Key.string k)
             (match node.symbol with None -> "" | Some s -> s)
+            (node.arg_string ())
             (node.val_string ())
-            (if S.mem node stack_nodes then
-               Colors.grey
-             else
-               (if node.is_filthy () then Colors.red else Colors.blue))
+            ( if node.is_stacked () then Colors.grey
+              else if node.is_filthy () then Colors.red
+              else if node.check_seqno == !global_seqno then Colors.green
+              else if node.repair_seqno == !global_seqno then Colors.purple
+              else Colors.blue )
           ;
           (* dump force and mutation targets of the node: *)
           List.iter begin fun ((tgt:debug), edge_is_dirty) ->
             Printf.fprintf out "  n%d -> n%d [color=%s penwidth=%d];\n" node.id tgt.id
-              (if edge_is_dirty () then Colors.red else Colors.blue)
-              (if edge_is_dirty () then 4          else 1)
+              (if edge_is_dirty () then "red" else "blue")
+              (if edge_is_dirty () then 8     else 1)
           end node.force_tgts ;
           List.iter begin fun (tgt:debug) ->
             Printf.fprintf out "  n%d -> n%d [style=dotted,label=\"\"];\n"
       Printf.fprintf out "digraph dcg_%d {\n" (!global_seqno) ;
       Printf.fprintf out "  node [fontname=\"sans-serif\"];\n" ;
       Printf.fprintf out "  node [shape=box style=\"rounded,filled\"];\n" ;
-      ignore ( walk thunk.meta.debug S.empty ) ;
+      let visited = S.empty in
+      let visited = walk thunk.meta.debug visited in
+      let visited = S.fold (fun node visited -> walk node visited) stack_nodes visited in
+      ignore visited ;
       Printf.fprintf out "}\n" ;
       close_out out
 
+echo "removed dot files and associated PDFs"
+rm -f *.dot *.dot.pdf
+echo "generating PDFs from dot..(be patient).."
+for i in *.dot ; do dot -Tpdf $i > $i.pdf ; done ; open *.dot.pdf