Replace ffs with a faster table-based implementation.

plum-umd · Sep 27, 2015 · 6bab504 · 6bab504
1 parent 75a9437
commit 6bab504
Show file tree

Hide file tree

Showing 11 changed files with 226 additions and 25 deletions.
diff --git a/_tags b/_tags
@@ -3,5 +3,6 @@
 <src/core/*> : for-pack(Adapton)
 <src/collections> : include
 <src/collections/*> : for-pack(Adapton)
+<misc> : -traverse
 true: package(core, unix, num, ppx_deriving.std)
 true: thread, debug
diff --git a/misc/ffs/Makefile b/misc/ffs/Makefile
@@ -0,0 +1,10 @@
+
+all : benchffs.native
+
+debug : benchffs.d.byte
+
+clean :
+	ocamlbuild -clean
+
+%.native %.byte :
+	ocamlbuild  -use-ocamlfind -no-links $@ --
diff --git a/misc/ffs/README.md b/misc/ffs/README.md
@@ -0,0 +1 @@
+This directory contains a benchmark of various implementations of ffs.
diff --git a/misc/ffs/_tags b/misc/ffs/_tags
@@ -0,0 +1,3 @@
+true: package(benchmark)
+<*.byte>: custom
+<*.{byte,native}>: linkdep(ffs_stubs.o)
diff --git a/misc/ffs/benchffs.ml b/misc/ffs/benchffs.ml
@@ -0,0 +1,154 @@
+(* loop-based *)
+let rec ffs_loop x = if x = 0 then 0 else
+    let rec loop t r =
+        if (x land t) <> 0 then r
+        else loop (t lsl 1) (r + 1)
+    in loop 1 1
+
+(* another loop-based *)
+let rec ffs_loop2 x = if x = 0 then 0 else
+    let rec loop r =
+        if (x land (1 lsl r)) <> 0 then r + 1
+        else loop (r + 1)
+    in loop 0
+
+(* char-table based *)
+let ffs_table shift =
+    let size = 1 lsl shift in
+    let mask = size - 1 in
+    let table = Bytes.init size begin fun x -> Char.unsafe_chr begin
+        if x = 0 then 0 else
+        let rec loop r = if (x lsr r) land 1 <> 0 then r else loop (r + 1) in loop 0 + 1
+    end end in
+    let rec ffs x r =
+        let r' = Char.code (Bytes.unsafe_get table (x land mask)) in
+        if r' <> 0 then r + r' else ffs (x lsr shift) (r + shift)
+    in
+    fun x -> if x = 0 then 0 else ffs x 0
+
+(* same as ffs_table, to see the effect of code movement *)
+let ffs_table_dup shift =
+    let size = 1 lsl shift in
+    let mask = size - 1 in
+    let table = Bytes.init size begin fun x -> Char.unsafe_chr begin
+        if x = 0 then 0 else
+        let rec loop r = if (x lsr r) land 1 <> 0 then r else loop (r + 1) in loop 0 + 1
+    end end in
+    let rec ffs x r =
+        let r' = Char.code (Bytes.unsafe_get table (x land mask)) in
+        if r' <> 0 then r + r' else ffs (x lsr shift) (r + shift)
+    in
+    fun x -> if x = 0 then 0 else ffs x 0
+
+(* another char-table based *)
+let ffs_table2 shift =
+    let size = 1 lsl shift in
+    let mask = size - 1 in
+    let table = Bytes.init size begin fun x -> Char.unsafe_chr begin
+        if x = 0 then 0 else
+        let rec loop r = if (x lsr r) land 1 <> 0 then r else loop (r + 1) in loop 0 + 1
+    end end in
+    let rec ffs x r =
+        if r > 63 then 0 else
+        let r' = Char.code (Bytes.unsafe_get table (x land mask)) in
+        if r' <> 0 then r + r' else ffs (x lsr shift) (r + shift)
+    in
+    fun x -> ffs x 0
+
+(* int-table based *)
+let ffs_table_int shift =
+    let size = 1 lsl shift in
+    let mask = size - 1 in
+    let table = Array.init size begin fun x ->
+        if x = 0 then 0 else
+        let rec loop r = if (x lsr r) land 1 <> 0 then r else loop (r + 1) in loop 0 + 1
+    end in
+    let rec ffs x r =
+        let r' = table.(x land mask) in
+        if r' <> 0 then r + r' else ffs (x lsr shift) (r + shift)
+    in
+    fun x -> if x = 0 then 0 else ffs x 0
+
+(* switch-table based *)
+let ffs_switch =
+    let shift = 4 in
+    let size = 1 lsl shift in
+    let mask = size - 1 in
+    let rec ffs x r =
+        let r' = match x land mask with
+            | 0 -> 0
+            | 1 -> 1
+            | 2 -> 2
+            | 3 -> 1
+            | 4 -> 3
+            | 5 -> 1
+            | 6 -> 2
+            | 7 -> 1
+            | 8 -> 4
+            | 9 -> 1
+            | 10 -> 2
+            | 11 -> 1
+            | 12 -> 3
+            | 13 -> 1
+            | 14 -> 2
+            | 15 -> 1
+            | _ -> assert false
+        in
+        if r' <> 0 then r + r' else ffs (x lsr shift) (r + shift)
+    in
+    fun x -> if x = 0 then 0 else ffs x 0
+
+(* c-stub based *)
+external ffs_ext : int -> int = "ml_ffs"
+external ffs_ext_noalloc : int -> int = "ml_ffs" "noalloc"
+external ffs_ext_intrinsic : int -> int = "ml_ffs_intrinsic"
+external ffs_ext_intrinsic_noalloc : int -> int = "ml_ffs_intrinsic" "noalloc"
+external ffs_ext_print : int -> int = "ml_ffs_print"
+
+(* ocaml 4.03 *)
+(* external ffs_ext_untagged : (int [@untagged]) -> (int [@untagged]) = "ffsl" *)
+(* external ffs_ext_untagged_noalloc : (int [@untagged]) -> (int [@untagged]) = "ffsl" "noalloc" *)
+
+open Benchmark
+
+let () =
+    (* sanity check *)
+    for k = 0 to 63 do Format.printf "%016x %2d@." (1 lsl k) (ffs_ext_print (1 lsl k)) done;
+
+    let time = if Array.length Sys.argv > 1 then int_of_string Sys.argv.(1) else 1 in
+    let repeat = if Array.length Sys.argv > 2 then int_of_string Sys.argv.(2) else 3 in
+    Array.iter begin fun size ->
+        let xs = Array.init size (fun _ -> (Random.bits () lsl 60) lxor (Random.bits () lsl 30) lxor Random.bits ()) in
+        xs.(0) <- 0;
+        xs.(1) <- max_int;
+        xs.(2) <- min_int;
+        let mapffs ffs = Array.map ffs xs in
+        let runffs ffs = ignore @@ mapffs ffs in
+        let factors = [
+            ("ffs_loop", runffs, ffs_loop);
+            ("ffs_loop2", runffs, ffs_loop2);
+            ("ffs_table 8", runffs, ffs_table 8);
+            ("ffs_table_dup 8", runffs, ffs_table_dup 8);
+            ("ffs_table2 8", runffs, ffs_table2 8);
+            ("Ffs.ffs_table 8", runffs, Ffs.ffs_table 8);
+            ("ffs_table_int 8", runffs, ffs_table_int 8);
+            ("ffs_ext", runffs, ffs_ext);
+            ("ffs_ext_noalloc", runffs, ffs_ext_noalloc);
+            ("ffs_ext_intrinsic", runffs, ffs_ext_intrinsic);
+            ("ffs_ext_intrinsic_noalloc", runffs, ffs_ext_intrinsic_noalloc);
+            (*("ffs_ext_untagged", runffs, ffs_ext_untagged);*)
+            (*("ffs_ext_untagged_noalloc", runffs, ffs_ext_untagged_noalloc);*)
+            ("ffs_switch", runffs, ffs_switch);
+            ("ffs_table 7", runffs, ffs_table 7);
+            ("ffs_table 6", runffs, ffs_table 6);
+            ("ffs_table 5", runffs, ffs_table 5);
+            ("ffs_table 4", runffs, ffs_table 4);
+        ] in
+
+        (* another sanity check *)
+        List.iter begin fun ( label, _, ffs ) ->
+            Format.printf "%s: %B@." label (mapffs ffs = mapffs ffs_ext)
+        end factors;
+
+        tabulate @@ throughputN ~repeat time factors
+    end [| 100; 10000 |]
diff --git a/misc/ffs/ffs.ml b/misc/ffs/ffs.ml
@@ -0,0 +1,13 @@
+(* test the overhead of a different module *)
+let ffs_table shift =
+    let size = 1 lsl shift in
+    let mask = size - 1 in
+    let table = Bytes.init size begin fun x -> Char.unsafe_chr begin
+        if x = 0 then 0 else
+        let rec loop r = if (x lsr r) land 1 <> 0 then r else loop (r + 1) in loop 0 + 1
+    end end in
+    let rec ffs x r =
+        let r' = Char.code (Bytes.unsafe_get table (x land mask)) in
+        if r' <> 0 then r + r' else ffs (x lsr shift) (r + shift)
+    in
+    fun x -> if x = 0 then 0 else ffs x 0
diff --git a/misc/ffs/ffs_stubs.c b/misc/ffs/ffs_stubs.c
@@ -0,0 +1,17 @@
+#include <stdio.h>
+#include <strings.h>
+#include <caml/memory.h>
+#include <caml/mlvalues.h>
+
+CAMLprim value ml_ffs(value x) {
+    return Val_int(ffsl(Long_val(x)));
+}
+
+CAMLprim value ml_ffs_intrinsic(value x) {
+    return Val_int(__builtin_ffsl(Long_val(x)));
+}
+
+CAMLprim value ml_ffs_print(value x) {
+    printf("%016lx %2d %2d    %016lx %2d %2d\n", Long_val(x), ffsl(Long_val(x)), ffs(Long_val(x)), (long) Int_val(x), ffsl(Int_val(x)), ffs(Int_val(x)));
+    return Val_int(ffsl(Long_val(x)));
+}
diff --git a/misc/ffs/myocamlbuild.ml b/misc/ffs/myocamlbuild.ml
@@ -0,0 +1,7 @@
+open Ocamlbuild_plugin;;
+
+dispatch begin function
+    | After_rules -> pdep ["link"] "linkdep" (fun param -> [param])
+    | _ -> ()
+end
+
diff --git a/src/collections/spreadTree.ml b/src/collections/spreadTree.ml
@@ -74,15 +74,6 @@
     defined and used separately from the usual cases of the structure,
     which are defined in the usual (eager) fashion.
 *)
-(* http://en.wikipedia.org/wiki/Find_first_set *)
-let rec ffs x =
-  if x = 0 then 0
-  else
-    let rec loop t r =
-      if (x land t) = 0 then r
-      else loop (t lsl 1) (r + 1)
-    in loop 1 0
-
 module type S = sig
   type elt
   type name
@@ -278,7 +269,7 @@ struct
       match list with
       | [] -> `Nil
       | x :: xs ->
-        if ffs (Elt.hash 0 (data_of x)) >= gran_level then
+        if Bits.ffs0 (Elt.hash 0 (data_of x)) >= gran_level then
           let nm1, nm2 = Name.fork (name_of x) in
           if cons_first then
             `Cons((data_of x), `Name(nm1, `Art (St.List.Art.cell nm2 (loop xs))))
@@ -458,7 +449,7 @@ struct
           ( match list with
           | `Nil -> rope, `Nil
           | `Cons (hd, tl) ->
-            let hd_lev = ffs (Elt.hash 0 hd) in
+            let hd_lev = Bits.ffs0 (Elt.hash 0 hd) in
             if rope_lev <= hd_lev && hd_lev <= parent_lev then (
               match nm_opt with
               | None ->
@@ -601,7 +592,7 @@ struct
          ( match list with
            | `Nil -> (`Nil, rev)
            | `Cons(x, xs) ->
-              let hd_lev = ffs (Elt.hash 0 x) in
+              let hd_lev = Bits.ffs0 (Elt.hash 0 x) in
               if lo <= hd_lev && hd_lev <= hi then (
                 match no with
                 | None ->

diff --git a/src/core/bits.ml b/src/core/bits.ml
@@ -0,0 +1,15 @@
+(* http://en.wikipedia.org/wiki/Find_first_set *)
+let ffs0 =
+    (* zero-index, i.e., like ctz (count trailing zero) but returns 0 for 0 *)
+    let shift = 8 in
+    let size = 1 lsl shift in
+    let mask = size - 1 in
+    let table = Bytes.init size begin fun x -> Char.unsafe_chr begin
+        if x = 0 then 0 else
+        let rec loop r = if (x lsr r) land 1 <> 0 then r else loop (r + 1) in loop 0 + 1
+    end end in
+    let rec ffs x r =
+        let r' = Char.code (Bytes.unsafe_get table (x land mask)) in
+        if r' <> 0 then r + r' else ffs (x lsr shift) (r + shift)
+    in
+    fun x -> if x = 0 then 0 else ffs x 0 - 1
diff --git a/src/core/name.ml b/src/core/name.ml
@@ -1,14 +1,3 @@
-(* http://en.wikipedia.org/wiki/Find_first_set *)
-(* TODO: Find a faster way to do this that's still portable;
-   e.g., on x86 there's a special machine instruction. *)
-let rec ffs x =
-  if x = 0 then 0
-  else
-    let rec loop t r =
-      if (x land t) = 0 then r
-      else loop (t lsl 1) (r + 1)
-    in loop 1 0
-
 module type S =
 sig
   include Data.S
@@ -39,7 +28,7 @@ struct
   let of_string s = 
     let h = Hashtbl.hash (Symbol s) in
     { hash = h ; 
-      height = ffs h ; 
+      height = Bits.ffs0 h ;
       tree=Symbol s }
 
   let pair k1 k2 =     
@@ -72,7 +61,7 @@ struct
       assert ( !next_label > l ) ; (* Overflow is an error. *)
       let hash = Hashtbl.hash (Label (l, seed)) in
       { hash = hash ;
-        height = ffs hash ;
+        height = Bits.ffs0 hash ;
         tree = Label ( l, seed ) }
 
   let gensym = make_nondet 0
Original file line number	Diff line number	Diff line change
		@@ -0,0 +1 @@
		This directory contains a benchmark of various implementations of ffs.