Commits

jprider63 committed 8b52d12 Merge

merged

Comments (0)

Files changed (9)

Benchmarks/BenchmarkAdapton/runbenchmarkadapton.ml

         | `List task ->
             fun ( xs, _, _, b ) ->
                 let yss = Array.init !opt_repeat_count (fun _ -> task xs) in
-                (fun () -> Array.iter (fun ys -> ignore (AFloatList.take ys !opt_take_count)) yss)
+                (fun () -> Array.iter (fun ys -> ignore (AFloatList.take !opt_take_count ys)) yss)
         | `One task ->
             fun ( xs, _, _, b ) ->
                 let ys = Array.init !opt_repeat_count (fun _ -> task xs) in
         | `Flip task ->
             fun ( xs, _, _, b ) ->
                 let yss = Array.init !opt_repeat_count (fun _ -> task xs b) in
-                (fun () -> Array.iter (fun ys -> ignore (AFloatList.take ys !opt_take_count)) yss)
+                (fun () -> Array.iter (fun ys -> ignore (AFloatList.take !opt_take_count ys)) yss)
         | `ExpTree ->
             failwith "exptree"
     in

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/AdaptonUtil/AList.ml

             to_ids [] xs
 
         (** Create a regular list from the first [k] elements of an Adapton list. *)
-        let take xs k =
-            let rec take acc xs k = if k = 0 then List.rev acc else match force xs with
-                | `Cons ( x, xs ) -> take (x::acc) xs (pred k)
+        let take k xs =
+            let rec take k xs acc = if k = 0 then List.rev acc else match force xs with
+                | `Cons ( x, xs ) -> take (pred k) xs (x::acc)
                 | `Nil -> List.rev acc
             in
-            take [] xs k
+            take k xs []
 
         (** Return the head of an Adapton list. *)
         let hd xs = match force xs with

Source/AdaptonUtil/Signatures.ml

         val force : t -> t'
         val to_list : t -> data list
         val to_ids : t -> int list
-        val take : t -> int -> data list
+        val take : int -> t -> data list
         val hd : t -> data
         val tl : t -> t
         val const : t' -> t
     val force : 'a alist -> 'a alist'
     val to_list : 'a alist -> 'a list
     val to_ids : 'a alist -> int list
-    val take : 'a alist -> int -> 'a list
+    val take : int -> 'a alist -> 'a list
     val hd : 'a alist -> 'a
     val tl : 'a alist -> 'a alist
     module type BasicS = AListType.BasicS

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 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' *)
             debug : debug ; (* 0 words when ADAPTON_LOG=false *)
         }
         and 'a state =
         and receipt = { check : 'a . (bool -> 'a) -> 'a }
         and 'a repair = { repair : 'b . ('a * receipt -> 'b) -> 'b }
         and dependency = { (* 3 words (meta shared with 'a thunk) *)
-            mutable dirty : bool;
+            mutable flag : flag;
             mutable receipt : receipt;
             dependent : meta;
             dependee  : meta; (* XXX -- For debugging *)
         }
+        and flag =
+            | Clean
+            | Dirty
+            | Obsolete
         and mut_edge = {
           mut_source : meta ; (* source of mutation (performs direct ref-like mutation, or key-based thunk mutation). *)
           mut_target : meta ; (* target of mutation. *) (* TODO-- this field may not be required. *)
         begin match !lazy_stack with
           | ( dependent, dependencies, _mutations_ )::_ ->
               let dependency = Dependents.merge m.meta.dependents
-                { dirty=false; receipt; dependent; dependee=m.meta }
+                { flag=Clean; receipt; dependent; dependee=m.meta }
               in
               (* an existing dependency may be reused *)
-              dependency.dirty <- false;
+              dependency.flag <- Clean;
               dependency.receipt <- receipt;
               dependencies := dependency::!dependencies;
 
            mut_tgts=[];
            force_tgts=[];
            is_filthy=(fun _ -> failwith "is_filthy");
+           arg_string=(fun _ -> "?");
            val_string=(fun _ -> "?");
+           check_seqno=(-1);
+           repair_seqno=(-1);
          }
          ELSE () END)
 
       let rec dirty = function
         | d::ds ->
             dirty begin Dependents.fold begin fun d ds ->
-              if d.dirty then
-                ds
-              else begin
+              if d.flag == Clean then 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;
+                d.flag <- Dirty;
                 IFDEF ADAPTON_LOG THEN Log.usr_hooks.Log.output_graph () END ;
                 d.dependent.dependents::ds
-              end
+              end else (* either Clean or Obsolete *)
+                ds
             end d ds end
         | [] ->
             ()
       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
           Log.more (match thunk.meta.debug.symbol with None -> "" | Some s -> s) ;
         ) END ;
 
-      (* add self to call stack and evaluate *)
+      (* remove existing dependencies, add self to call stack and evaluate *)
       incr Statistics.Counts.evaluate;
+      begin match thunk.state with
+        | Value ( _, _, _, dependencies, _ ) ->
+          List.iter (fun d -> d.flag <- Obsolete) dependencies
+        | Thunk _ | Mutable _ ->
+          ()
+      end;
       let dependencies = ref [] in (* No dependencies, initially. *)
       let mutations = ref [] in (* No mutations, initially. *)
       lazy_stack := ( thunk.meta, dependencies, mutations )::!lazy_stack;
         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;
       let thunk_dependencies = List.rev !dependencies in
       let _ = IFDEF ADAPTON_LOG THEN (
         let force_tgts : (debug * (unit -> bool)) list =
-          List.map (fun dep -> (dep.dependee.debug, fun _ -> dep.dirty))
+          List.map (fun dep -> (dep.dependee.debug, fun _ -> dep.flag == Dirty))
             thunk_dependencies
         in
         let mut_tgts : debug list = List.rev !mutations in
       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
                 | d::ds ->
                     IFDEF ADAPTON_LOG THEN (
                       Log.more (Printf.sprintf "(&%d,%s,&%d)" d.dependent.id
-                                  (if d.dirty then "⚑" else "⚐") d.dependee.id)
+                                  (if d.flag == Dirty then "⚑" else "⚐") d.dependee.id)
                     ) END ;
-                    if d.dirty then begin
-                      d.dirty <- false;
+                    if d.flag == Dirty then begin
+                      (*
+                      d.flag <- Clean;
                       IFDEF ADAPTON_LOG THEN Log.usr_hooks.Log.output_graph () END ;
+                      *)
                       IFDEF ADAPTON_LOG THEN (
                         Log.more (Printf.sprintf "(&%d,⚐,&%d)" d.dependent.id d.dependee.id);
                       ) END ;
-                      d.receipt.check begin fun c ->
-                        if c then (incr Statistics.Counts.clean; repair_deps ds)
-                        else cont (evaluate ())
-                      end
+                      let check_result =
+                        d.receipt.check begin fun c ->
+                          if c then (incr Statistics.Counts.clean; repair_deps ds)
+                          else cont (evaluate ())
+                        end
+                      in
+                      IFDEF ADAPTON_LOG THEN (
+                        if d.flag == Dirty then
+                          Log.usr_hooks.Log.output_graph ()
+                      ) END ;
+                      d.flag <- Clean; (* Need to reset dirty flag here, resetting beforehand is not enough. *)
+                      check_result
                     end else (
+                      assert (d.flag == Clean);
                       repair_deps ds
                     )
                 | [] -> (
                     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 redgrey = "lightpink4"
+        let grey    = "grey"
+        let purple  = "mediumorchid1"
       end
       in
       let module S = Set.Make(
         open_out (Printf.sprintf "dcg-%03d-%03d.dot" (!global_seqno) (!graph_seqno))
       in
       incr graph_seqno ;
-      let stack_nodes : S.t = List.fold_right S.add
+      let stack : S.t = List.fold_right S.add
         (List.map (fun (meta,_,_) -> meta.debug) (!lazy_stack))
         S.empty
       in
         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_filthy () && not (S.mem node stack) then Colors.red
+              else if node.is_filthy () && (S.mem node stack) then Colors.redgrey
+              else if S.mem node stack then Colors.grey
+              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 visited in
+      ignore visited ;
       Printf.fprintf out "}\n" ;
       close_out out
 

Test/TestAdapton/TestAList.ml

 let make_correctness_testsuite (module L : AdaptonUtil.Signatures.AListType) =
     let module I = L.Make (AdaptonUtil.Types.Int) in
 
-    let test_alist_op_with_test ?(count=25) ?incl op a_op ~test =
+    let test_alist_op_with_test ?(count=40) ?incl op a_op ~test =
         Gc.compact (); (* try to make GC effects consistent across tests *)
-        QC.forall ~count ?incl (QC.pair (QC.list QC.int) (QC.list (QC.list (QC.triple QC.bool QC.int QC.int)))) begin fun ( xs, kss ) ->
+        QC.forall ~count ?incl (QC.triple (QC.list QC.int) QC.int (QC.list (QC.pair (QC.list (QC.triple QC.bool QC.int QC.int)) QC.int))) begin fun ( xs, o, kss ) ->
             let n = List.length xs in
             let ys = op xs in
 
             let xs' = I.of_list xs in
             let ys' = a_op xs' in
 
-            test ~msg:"initial" ys ys';
+            test ~msg:"initial" (abs o mod (n + 1) + 1) ys ys';
 
-            ignore begin List.fold_left begin fun ( xs, xs', n ) ks ->
+            ignore begin List.fold_left begin fun ( xs, xs', n ) ( ks, o ) ->
                 let xs, n' = List.fold_left begin fun ( xs, n ) ( i, k, x ) ->
                     if n = 0 then
                         ( [ x ], 1 )
                     ( xs', ys' )
                 end in
 
-                test ~msg:"update" ys ys';
+                test ~msg:"update" (abs o mod (n + 1) + 1) ys ys';
                 ( xs, xs', n' )
             end ( xs, xs', n ) kss end
         end ()
     in
 
-    let test_alist_op = test_alist_op_with_test ~test:(fun ~msg expected actual -> assert_list_equal ~msg expected (I.to_list actual)) in
+    let test_alist_op = test_alist_op_with_test ~test:begin fun ~msg length expected actual ->
+        let rec take k xs acc = if k = 0 then List.rev acc else match xs with
+            |  x::xs -> take (pred k) xs (x::acc)
+            | [] -> List.rev acc
+        in
+        assert_list_equal ~msg (take length expected []) (I.take length actual)
+    end in
 
     "Correctness" >::: [
         "filter" >:: QC.forall QC.int begin fun p ->
             let fn = (+) in
             let tfold_fn = I.memo_tfold fn in
             test_alist_op_with_test
-                ~test:(fun ~msg expected actual -> assert_int_equal ~msg expected (I.AData.force actual))
+                ~test:(fun ~msg _ expected actual -> assert_int_equal ~msg expected (I.AData.force actual))
                 (List.fold_left fn 0) (fun xs' -> tfold_fn (I.const (`Cons ( 0, xs' )))) (* prepend 0 to avoid empty lists *)
         end;
 
         "quicksort" >:: begin fun () ->
             let quicksort = I.memo_quicksort compare in
-            test_alist_op
-                ~incl:
-                    [ ( [ 8; 0; -7; 3; -2; 7; -1 ],
-                        [ [ ( true, -3, -4 ); ( false, -8, 6 ); ( true, 5, 8 ); ( true, 0, 6 ); ( true, -5, -2 ) ];
-                            [ ( false, -4, -9 ) ];
-                            [ ( false, -1, -7 ); ( false, -7, 5 ); ( true, -2, -3 ); ( true, -5, -6 ); ( false, -8, -7 ) ];
-                            [ ( false, -9, -2 ); ( true, -8, 6 ); ( true, -7, -4 ); ( false, -1, -6 ); ( true, -4, 0 ); ( true, 1, 6 ) ];
-                            [ ( true, -9, -5 ); ( true, 5, 5 ); ( false, 1, 1 ); ( true, 2, -9 ); ( false, 8, -8 ); ( false, 6, -4 ); ( false, 5, 6 ); ( true, -6, -6 ) ];
-                            [ ( false, -2, -3 ); ( true, 7, 4 ); ( false, -9, -5 ) ] ] ) ]
-                (List.sort compare) quicksort
+            test_alist_op (List.sort compare) quicksort
         end;
 
         "mergesort" >:: begin fun () ->

Test/nominaladaptontest.ml

     let _ =
       List.fold_left begin fun len batch_edit ->
         let len = Apparatus.do_batch_edit list len batch_edit in
-        output_graph () ;
+        (*output_graph () ;*)
         print_list ~lab:"☞ input (prepended 0 is elided)" (AKLi.force list) ;
         let out_int  = (AKLi.AData.force out) in
         output_graph () ;
+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