Commits

Yit Phang Khoo committed 0522383

Add SAList.tfold and SAList.SAData as its output type, as well as add it to the SAList benchmark.

  • Participants
  • Parent commits 9333712

Comments (0)

Files changed (4)

Source/Adapton/SAList.ml

                 | _ -> false
         end)
 
+        (** Self-adjusting values for a specific type, return by certain list operations. *)
+        module SAData = M.Make (R)
+
         (** Value contained by self-adjusting lists for a specific type. *)
         type data = R.t
 
                 | `Cons ( x, xs ) -> let acc = f x acc in `Cons ( acc, scan xs acc )
                 | `Nil -> `Nil
             end
+
+        (** Create memoizing constructor and updater that tree-folds a self-adjusting list with an associative fold function. *)
+        let memo_tfold f =
+            let fold_pairs, _ = L.memo2 (module Types.Int) (module L) begin fun fold_pairs seed xs -> match L.force xs with
+                | `Cons ( x', xs' ) as xs'' ->
+                    if L.hash seed xs mod 2 == 0 then
+                        `Cons ( x', fold_pairs seed xs' )
+                    else begin match L.force xs' with
+                        | `Cons ( y', ys' ) ->
+                            `Cons ( f x' y', fold_pairs seed ys' )
+                        | `Nil ->
+                            xs''
+                    end
+                | `Nil ->
+                    `Nil
+            end in
+            let tfold, update_tfold = SAData.memo2 (module Types.Seeds) (module L) begin fun tfold seeds xs -> match L.force xs with
+                | `Cons ( x', xs' ) ->
+                    begin match L.force xs' with
+                        | `Cons _ ->
+                            let seed, seeds = Types.Seeds.pop seeds in
+                            force (tfold seeds (fold_pairs seed xs))
+                        | `Nil ->
+                            x'
+                    end
+                | `Nil ->
+                    failwith "tfold"
+            end in
+            let seeds = Types.Seeds.make () in
+            let tfold xs = tfold seeds xs in
+            let update_tfold m xs = update_tfold m seeds xs in
+            ( tfold, update_tfold )
     end
 
 

Source/Adapton/Signatures.ml

         type sa
         type 'a thunk
         type data
+        module SAData : SAType.S with type sa = sa and type 'a thunk = 'a thunk and type data = data and type t = data thunk
         type t
         type t' = [ `Cons of data * t | `Nil ]
         val hash : int -> t -> int
         val memo_scan
             : (module SAListType.BasicS with type sa = sa and type data = 'a and type t = 'b)
                 -> ('a -> data -> data) -> ('b -> data -> t) * (t -> 'b -> data -> unit)
+        val memo_tfold : (data -> data -> data) -> (t -> SAData.t) * (SAData.t -> t -> unit)
     end
 
     (** Module type for self-adjusting lists for a specific type. *)

Test/TestAdapton/TestSAList.ml

 let make_regression_testsuite (module L : Adapton.Signatures.SAListType) =
     let module I = L.Make (Adapton.Types.Int) in
 
-    let test_salist_op ?(count=25) ?incl op sa_op =
+    let test_salist_op_with_test ?(count=25) ?incl op sa_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 ) ->
             let n = List.length xs in
             let ys = op xs in
-            let zs = ys in
 
             let xs' = I.of_list xs in
             let ys' = sa_op xs' in
-            let zs' = I.to_list ys' in
 
-            assert_list_equal ~msg:"initial" zs zs';
+            test ~msg:"initial" ys ys';
 
             ignore begin List.fold_left begin fun ( xs, xs', n ) ks ->
                 let xs, n' = List.fold_left begin fun ( xs, n ) ( i, k, x ) ->
                             ( delete k [] xs, pred n )
                 end ( xs, n ) ks in
                 let ys = op xs in
-                let zs = ys in
 
                 let xs', ys' = try
                     ignore begin List.fold_left begin fun n ( i, k, x ) ->
                     let ys' = sa_op xs' in
                     ( xs', ys' )
                 in
-                let zs' = I.to_list ys' in
 
-                assert_list_equal ~msg:"update" zs zs';
+                test ~msg:"update" ys ys';
                 ( xs, xs', n' )
             end ( xs, xs', n ) kss end
         end ()
     in
 
+    let test_salist_op = test_salist_op_with_test ~test:(fun ~msg expected actual -> assert_list_equal ~msg expected (I.to_list actual)) in
+
     "Correctness" >::: [
         "filter" >:: QC.forall QC.int begin fun p ->
             let pred = (<) p in
             test_salist_op (List.map fn) map_fn
         end;
 
+        "tfold" >:: begin fun () ->
+            let fn = (+) in
+            let tfold_fn, _ = I.memo_tfold fn in
+            test_salist_op_with_test
+                ~test:(fun ~msg expected actual -> assert_int_equal ~msg expected (I.SAData.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_salist_op

Test/runbenchmarksalist.ml

 let list_map_task (type a) (module L : Adapton.Signatures.SAListType.S with type t = a and type data = float) =
     fst (L.memo_map (module L) (fun x -> x *. 3. +. x *. 7. +. x *. 9.))
 
+let list_tfold_task (type a) (module L : Adapton.Signatures.SAListType.S with type t = a and type data = float) =
+    let tfold = fst (L.memo_tfold (+.)) in
+    (fun xs -> L.const (`Cons ( L.SAData.force (tfold xs), L.const `Nil )))
+
 let list_quicksort_task (type a) (module L : Adapton.Signatures.SAListType.S with type t = a and type data = float) =
     fst (L.memo_quicksort Pervasives.compare)
 
 let tasks = [
     ( "filter", list_filter_task );
     ( "map", list_map_task );
+    ( "tfold", list_tfold_task );
     ( "quicksort", list_quicksort_task );
 ]