[WIP] Add IntArray

lib/domainslib.ml

@@ -1,2 +1,3 @@
 module Chan = Chan
 module Task = Task
+module IntArray = Intarray.IntArray

lib/intarray.ml

@@ -0,0 +1,68 @@
+module Int64Array : sig
+  module Array : sig
+    type t
+    val create_uninitialised : int -> t
+    val get : t -> int -> int64
+    val set : t -> int -> int64 -> unit
+    val unsafe_get : t -> int -> int64
+    val unsafe_set : t -> int -> int64 -> unit
+    val unsafe_blit : t -> int -> t -> int -> int -> unit
+    val length : t -> int
+    val sub : t -> int -> int -> t
+    val copy : t -> t 
+  end
+end = struct
+  module Array = struct
+    type t = Bytes.t
+    let create_uninitialised sz = Bytes.create (sz * 8)
+    external set_raw_64 : Bytes.t -> int -> int64 -> unit = "%caml_bytes_set64"
+    external get_raw_64 : Bytes.t -> int -> int64 = "%caml_bytes_get64"
+    external unsafe_set_raw_64 : Bytes.t -> int -> int64 -> unit = "%caml_bytes_set64u"
+    external unsafe_get_raw_64 : Bytes.t -> int -> int64 = "%caml_bytes_get64u"
+    external unsafe_blit : Bytes.t -> int -> Bytes.t -> int -> int -> unit
+                     = "caml_blit_bytes" [@@noalloc]
+    let get arr i = get_raw_64 arr (i * 8)
+    let set arr i x = set_raw_64 arr (i * 8) x
+    let unsafe_get arr i = unsafe_get_raw_64 arr (i * 8)
+    let unsafe_set arr i x = unsafe_set_raw_64 arr (i * 8) x
+    let length a = (Bytes.length a) / 8
+    let sub a s len = Bytes.sub a (s * 8) (len * 8)
+    let copy = Bytes.copy
+  end
+end
+
+module IntArray : sig
+  module Array : sig
+    type t
+    val create_uninitialised : int -> t
+    val get : t -> int -> int
+    val set : t -> int -> int -> unit
+    val unsafe_get : t -> int -> int
+    val unsafe_set : t -> int -> int -> unit
+    val length : t -> int
+    val sub : t -> int -> int -> t
+    val copy : t -> t 
+    val blit : t -> int -> t -> int -> int -> unit
+  end
+end = struct
+  module Array = struct
+    type t = Int64Array.Array.t
+    let create_uninitialised = Int64Array.Array.create_uninitialised
+    let get arr i = Int64.to_int (Int64Array.Array.get arr i)
+    let set arr i x = Int64Array.Array.set arr i (Int64.of_int x)
+    let unsafe_get arr i = Int64.to_int (Int64Array.Array.unsafe_get arr i)
+    let unsafe_set arr i x = Int64Array.Array.unsafe_set arr i (Int64.of_int x)
+    let length = Int64Array.Array.length
+    let sub = Int64Array.Array.sub
+    let copy = Int64Array.Array.copy
+    let blit s1 ofs1 s2 ofs2 len =
+      if len < 0 || ofs1 < 0 || ofs1 > length s1 - len
+             || ofs2 < 0 || ofs2 > length s2 - len
+      then invalid_arg "Array.blit"
+      else Int64Array.Array.unsafe_blit s1 (ofs1 * 8) s2 (ofs2 * 8) (len * 8)
+  end
+end
+
+
+
+

lib/intarray.mli

@@ -0,0 +1,14 @@
+module IntArray : sig
+  module Array : sig
+    type t
+    val create_uninitialised : int -> t
+    val get : t -> int -> int
+    val set : t -> int -> int -> unit
+    val unsafe_get : t -> int -> int
+    val unsafe_set : t -> int -> int -> unit
+    val length : t -> int
+    val sub : t -> int -> int -> t
+    val copy : t -> t 
+    val blit : t -> int -> t -> int -> int -> unit
+  end
+end

test/dune

@@ -55,7 +55,7 @@
  (modules spectralnorm2_multicore)
  (modes native))
 
-(test
+(test 
  (name summed_area_table)
  (libraries domainslib)
  (modules summed_area_table)
@@ -66,3 +66,18 @@
  (libraries domainslib unix)
  (modules prefix_sum)
  (modes native))
+
+(test
+ (name mergesort_multicore)
+ (libraries domainslib)
+ (modules mergesort_multicore))
+
+(test
+ (name quicksort_multicore)
+ (libraries domainslib)
+ (modules quicksort_multicore))
+
+(test
+ (name test_intarray)
+ (libraries domainslib)
+ (modules test_intarray))

test/mergesort_multicore.ml

@@ -0,0 +1,98 @@
+module T = Domainslib.Task
+module A = Domainslib.IntArray
+
+let num_domains = try int_of_string @@ Sys.argv.(1) with _ -> 1
+let n = try int_of_string @@ Sys.argv.(2) with _ -> 1024
+let min = 128
+let pool = T.setup_pool ~num_domains:(num_domains - 1)
+
+open A
+
+let a = Array.create_uninitialised n 
+
+let init_part s e arr =
+  let my_state = Random.State.make_self_init () in
+  for i = s to e do
+    arr.(i) <- Random.State.int my_state n
+  done
+
+let _ = 
+T.parallel_for pool ~chunk_size:1 ~start:0 ~finish:(num_domains - 1)
+~body:(fun i -> init_part (i * n / num_domains) ((i+1) * n / num_domains - 1) a)
+
+let b = Array.create_uninitialised n
+
+type array_slice = {arr: A.Array.t; index: int; length: int}
+
+let print_array_slice s a =
+  print_string (s^"=");
+  for i = a.index to a.index + a.length - 1 do
+    Printf.printf "%d " a.arr.(i)
+  done;
+  print_endline ""
+
+let sort a =
+  for i = a.index to a.index + a.length - 2 do
+    for j = i + 1 to a.index + a.length - 1 do
+      if a.arr.(j) < a.arr.(i) then
+        let t = a.arr.(i) in
+        a.arr.(i) <- a.arr.(j);
+        a.arr.(j) <- t
+    done
+  done
+
+let merge a b res =
+  let rec loop ai bi ri =
+    match a.index + a.length - ai, b.index + b.length - bi with
+    | n, 0 -> Array.blit a.arr ai res.arr ri n
+    | 0, n -> Array.blit b.arr bi res.arr ri n
+    | _, _ ->
+        if a.arr.(ai) < b.arr.(bi) then begin
+          res.arr.(ri) <- a.arr.(ai);
+          loop (ai+1) bi (ri+1)
+        end else begin
+          res.arr.(ri) <- b.arr.(bi);
+          loop ai (bi+1) (ri+1)
+        end
+  in
+  loop a.index b.index res.index
+
+let rec merge_sort a b l =
+  if a.length <= min then begin
+    sort a;
+    a
+  end else
+    let a1= {a with index = a.index; length = a.length / 2} in
+    let b1 = {b with index = b.index; length = b.length / 2} in
+    let r1 = T.async pool (fun _ -> merge_sort a1 b1 (2*l+1)) in
+
+    let a2 = {a with index = a.index + a.length / 2;
+                length = a.length - a.length / 2} in
+    let b2 = {b with index = b.index + b.length / 2;
+                length = b.length - b.length / 2} in
+    let r2 = T.async pool (fun _ -> merge_sort a2 b2 (2*l+2)) in
+
+    let (r1, r2) = (T.await pool r1, T.await pool r2) in
+
+    if r1.arr != r2.arr then begin
+      if r2.arr == a.arr then begin
+        merge r1 r2 a;
+        a
+      end else begin
+        merge r1 r2 b;
+        b
+      end
+    end else if r1.arr == a.arr then begin
+      merge r1 r2 b;
+      b
+    end else begin
+      merge r1 r2 a;
+      a
+    end
+
+let _ =
+  let aslice = {arr = a; index = 0; length = n}in
+  let bslice = {arr = b; index = 0; length = n} in
+
+  let _r = merge_sort aslice bslice 0 in
+  T.teardown_pool pool

test/quicksort_multicore.ml

@@ -0,0 +1,70 @@
+let num_domains = try int_of_string Sys.argv.(1) with _ -> 1
+let n = try int_of_string Sys.argv.(2) with _ -> 2000
+
+module A = Domainslib.IntArray
+module T = Domainslib.Task
+
+open A
+
+let swap arr i j =
+  let temp = arr.(i) in
+  arr.(i) <- arr.(j);
+  arr.(j) <- temp
+
+let partition arr low high =
+  let x = arr.(high) and  i = ref (low-1) in
+  if (high-low > 0) then
+    begin
+      for j= low to high - 1 do
+        Domain.Sync.poll ();
+        if arr.(j) <= x then
+          begin
+            i := !i+1;
+                swap arr !i j
+          end
+      done
+    end;
+    swap arr (!i+1) high;
+    !i+1
+
+let rec quicksort_o arr low high =
+  match (high - low) <= 0 with
+  | true  -> ()
+  | false ->
+    let q = partition arr low high in
+    quicksort_o arr low (q-1);
+    quicksort_o arr (q+1) high
+
+let rec quicksort arr low high d =
+  match (high - low) <= 0 with
+  | true  -> ()
+  | false   ->
+    if d > 1 then
+      let q = partition arr low high in
+      let c = Domain.spawn (fun () -> quicksort arr low (q-1) (d/2)) in
+      quicksort arr (q+1) high (d/2 + (d mod 2));
+      Domain.join c
+    else begin
+      let q = partition arr low high in
+      quicksort arr low (q-1) d;
+      quicksort arr (q+1) high d
+    end
+
+let init_part s e arr =
+  let my_state = Random.State.make_self_init () in
+  for i = s to e do
+    arr.(i) <- Random.State.int my_state n
+  done
+
+let () =
+  let arr = Array.create_uninitialised n in
+  let domains = T.setup_pool ~num_domains:(num_domains - 1) in 
+  T.parallel_for domains ~chunk_size:1 ~start:0 ~finish:(num_domains - 1)
+  ~body:(fun i -> init_part (i * n / num_domains) ((i+1) * n / num_domains - 1) arr);
+   quicksort arr 0 (Array.length arr - 1) num_domains;
+  (* for i = 0 to  Array.length arr - 1 do
+    print_int arr.(i);
+    print_string "  "
+      done  *)
+  T.teardown_pool domains
+

test/test_intarray.ml

@@ -0,0 +1,17 @@
+open Domainslib.IntArray
+
+let () = 
+  let a = Array.create_uninitialised 10 in
+  for i = 0 to 9 do 
+    a.(i) <- i
+  done;
+  let b = Array.copy a in
+  for i = 0 to (Array.length b - 1) do 
+    assert (a.(i) = b.(i))
+  done;
+  let c = Array.create_uninitialised 3 in
+  Array.blit a 0 c 0 3;
+  assert (c.(0) = a.(0));
+  assert (c.(1) = a.(1));
+  assert (c.(2) = a.(2));
+  Printf.printf "ok"