Merge branch 'race-conditions' into benchmark-ready-par

Author: jazullo

src/Array.hs

@@ -240,7 +240,7 @@ copy_par src0 src_offset0 dst0 dst_offset0 len0 = copy_par' src0 src_offset0 dst
       then copy src src_offset dst dst_offset len
       else let !half = len `div` 2
                !(src_l, src_r) = splitAt half src
-               !(dst_l, dst_r) = splitAt (len-half) dst
+               !(dst_l, dst_r) = splitAt half dst
                left = copy_par' src_l 0 dst_l 0 half
                right = copy_par' src_r 0 dst_r 0 (len-half)
            in left `par` right `pseq` append left right
@@ -260,7 +260,7 @@ copy_par_m !src0 src_offset0 !dst0 dst_offset0 !len0 = copy_par_m' src0 src_offs
       else do
            let !half = len `div` 2
                !(src_l, src_r) = splitAt half src
-               !(dst_l, dst_r) = splitAt (len-half) dst
+               !(dst_l, dst_r) = splitAt half dst
            !left_f <- P.spawn_$ copy_par_m' src_l 0 dst_l 0 half
            !right <- copy_par_m' src_r 0 dst_r 0 (len-half)
            !left <- P.get left_f

src/DpsMergeSort4Par.hs

@@ -55,8 +55,10 @@ msortInplace src tmp =
         !(tmp1, tmp2)     = splitMid tmpA
         !(tmp3, tmp4)     = splitMid tmpB
         !(((src1', tmp1'), (src2', tmp2')), ((src3', tmp3'), (src4', tmp4')))
-                         = (msortInplace src1 tmp1 .||. msortInplace src2 tmp2) .||.
-                           (msortInplace src3 tmp3 .||. msortInplace src4 tmp4)
+                         = (.||||.) (msortInplace src1 tmp1) (msortInplace src2 tmp2)
+                                    (msortInplace src3 tmp3) (msortInplace src4 tmp4) 
+--                         = (msortInplace src1 tmp1 .||. msortInplace src2 tmp2) .||.
+--                           (msortInplace src3 tmp3 .||. msortInplace src4 tmp4) 
 --                         = tuple4 (msortInplace src1) tmp1 (msortInplace src2) tmp2
 --                                  (msortInplace src3) tmp3 (msortInplace src4) tmp4
         tmpA'            = A.append tmp1' tmp2'

src/Par.hs

@@ -8,6 +8,7 @@ import           Linear.Common
 import qualified Unsafe.Linear as Unsafe
 import           Control.DeepSeq ( NFData(..) )
 import           GHC.Conc ( par, pseq )
+import qualified Control.Monad.Par as P
 
 --------------------------------------------------------------------------------
 
@@ -37,9 +38,39 @@ tuple4 f1 x f2 y f3 z f4 a  = p `par` q `par` r `par` s `pseq` ((p,q), (r,s))
     r = f3 z
     s = f4 a
 
-{-# INLINE (.||.) #-}
-(.||.) :: (NFData a, NFData b) => a -. b -. (a,b)
-(.||.) = Unsafe.toLinear (\a -> Unsafe.toLinear (\b -> (a `par` b `pseq` (a,b))))
+{-# INLINABLE (.||.) #-}
+(.||.) :: (NFData a) => a -. a -. (a,a)
+--(.||.) = Unsafe.toLinear (\a -> Unsafe.toLinear (\b -> (a `par` b `pseq` (a,b))))
+(.||.) = Unsafe.toLinear (\a -> Unsafe.toLinear (\b -> P.runPar $ do
+                    i <- P.new
+                    j <- P.new
+                    P.fork (P.put_ i a)
+                    P.fork (P.put_ j b)
+                    a' <- P.get i 
+                    b' <- P.get j
+                    return (a', b') 
+  ))
+
+
+(.||||.) :: (NFData a) => a -. a -. a -. a -. ((a,a),(a,a))  
+(.||||.) = Unsafe.toLinear (\a -> 
+                Unsafe.toLinear (\b -> 
+                    Unsafe.toLinear (\c -> 
+                        Unsafe.toLinear (\d -> P.runPar $ do
+                            i <- P.new
+                            j <- P.new
+                            k <- P.new
+                            l <- P.new
+                            P.fork (P.put_ i a)
+                            P.fork (P.put_ j b)
+                            P.fork (P.put_ k c)
+                            P.fork (P.put_ l d)
+                            a' <- P.get i 
+                            b' <- P.get j
+                            c' <- P.get k
+                            d' <- P.get l
+                            return ((a', b'), (c', d')) 
+  ))))
 
 {-
 tuple2 :: (NFData a, NFData b) => (a -> b) -> a -> (a -> b) -> a -> (b, b)
@@ -88,4 +119,10 @@ tuple4 f x g y h z j w = ((f x, g y), (h z, j w))
 {-@ (.||.) :: x:a -> y:b -> { tup:_ | x == fst tup && y = snd tup } @-}
 (.||.) :: a -. b -. (a,b)
 a .||. b = (a,b)
+
+{-@ (.||||.) :: x:a -> y:a -> z:a -> w:a 
+                    -> { tup:_ | x == fst (fst tup) && y == snd (fst tup) &&
+                                 z == fst (snd tup) && w == snd (snd tup) } @-}
+(.||||.) :: (NFData a) => a -. a -. a -. a -. ((a,a),(a,a))  
+(.||||.) a b c d = ((a, b), (c, d)) 
 #endif