Commits

Yit Phang Khoo committed 9aad7ef Merge

Merge from default, which includes #245893f438bd that makes dirtying exact.

  • Participants
  • Parent commits 79b39a3, 245893f
  • Branches nominal

Comments (0)

Files changed (5)

File 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

File 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

File 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

File Source/AdaptonZoo/Adapton.ml

         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;
 
       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
+                ds
             end d ds end
         | [] ->
             ()
           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;
       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
                 | 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
+                    if d.flag == Dirty then begin
                       (*
-                      d.dirty <- false;
+                      d.flag <- Clean;
                       IFDEF ADAPTON_LOG THEN Log.usr_hooks.Log.output_graph () END ;
                       *)
                       IFDEF ADAPTON_LOG THEN (
                         end
                       in
                       IFDEF ADAPTON_LOG THEN (
-                        if d.dirty then
+                        if d.flag == Dirty then
                           Log.usr_hooks.Log.output_graph ()
                       ) END ;
-                      d.dirty <- false; (* Need to reset dirty flag here, resetting beforehand is not enough. *)
+                      d.flag <- Clean; (* Need to reset dirty flag here, resetting beforehand is not enough. *)
                       check_result
                     end else (
                       repair_deps ds

File 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 () ->