Fiddle with strictness and reboxing
authorRoman Leshchinskiy <rl@cse.unsw.edu.au>
Mon, 2 Nov 2009 12:58:23 +0000 (12:58 +0000)
committerRoman Leshchinskiy <rl@cse.unsw.edu.au>
Mon, 2 Nov 2009 12:58:23 +0000 (12:58 +0000)
This speeds up Quickhull by quite a bit

dph-base/Data/Array/Parallel/Arr/BUArr.hs
dph-base/Data/Array/Parallel/Base/Rebox.hs
dph-base/Data/Array/Parallel/Stream/Flat/Basics.hs
dph-base/Data/Array/Parallel/Stream/Flat/Combinators.hs
dph-base/Data/Array/Parallel/Stream/Segmented.hs
dph-prim-seq/Data/Array/Parallel/Unlifted/Sequential/Flat/Combinators.hs
dph-prim-seq/Data/Array/Parallel/Unlifted/Sequential/Flat/UArr.hs

index ccd8c0c..fcae2e9 100644 (file)
@@ -129,7 +129,7 @@ lengthMBU (MBUArr n _) = n
 
 
 -- | Class of elements that can be stored in unboxed arrays
-class HS e => UAE e where
+class (HS e, Rebox e) => UAE e where
   -- | Compute the size of an unboxed array with @n@ elements. The second
   -- argument is just for type inference and will not be inspected.
   --
@@ -485,7 +485,7 @@ mapBU f = unstreamBU . mapS f . streamBU
 
 -- |Reduce an unboxed array
 --
-foldlBU :: UAE b => (a -> b -> a) -> a -> BUArr b -> a
+foldlBU :: (Rebox a, UAE b) => (a -> b -> a) -> a -> BUArr b -> a
 {-# INLINE foldlBU #-}
 foldlBU f z = foldS f z . streamBU
 
index 5d3f22c..e1a43eb 100644 (file)
 
 
 module Data.Array.Parallel.Base.Rebox (
-  Rebox(..), Box(..)
+  Rebox(..), Box(..), Strict(..)
 ) where
 
 import Data.Array.Parallel.Base.Hyperstrict
 
 import GHC.Base   (Int(..), Char(..))
 import GHC.Float  (Float(..), Double(..))
+import GHC.Word   (Word8(..))
 
 class Rebox a where
   rebox :: a -> a
@@ -69,6 +70,10 @@ instance Rebox Double where
   {-# INLINE [0] dseq #-}
   dseq = seq
 
+instance Rebox Word8 where
+  rebox = id
+  dseq = seq
+
 instance (Rebox a, Rebox b) => Rebox (a :*: b) where
   {-# INLINE [0] rebox #-}
   rebox (x :*: y) = rebox x :*: rebox y
@@ -110,3 +115,9 @@ instance Rebox (Lazy a) where
   {-# INLINE [0] dseq #-}
   dseq (Lazy a) x = x
 
+data Strict a = Strict a
+
+instance Rebox (Strict a) where
+  rebox = id
+  dseq = seq
+
index 29a5ad2..6d4b633 100644 (file)
@@ -27,7 +27,7 @@ module Data.Array.Parallel.Stream.Flat.Basics (
 ) where
 
 import Data.Array.Parallel.Base (
-  (:*:)(..), MaybeS(..), EitherS(..), Box(..))
+  (:*:)(..), MaybeS(..), EitherS(..), Box(..), Strict(..))
 import Data.Array.Parallel.Stream.Flat.Stream
 
 -- | Empty stream
@@ -49,14 +49,14 @@ singletonS x = Stream next True 1 (sNoArgs "singletonS")
 --
 consS :: a -> Stream a -> Stream a
 {-# INLINE_STREAM consS #-}
-consS x (Stream next s n c) = Stream next' (JustS (Box x) :*: s) (n+1) ("consS" `sArgs` c)
+consS x (Stream next s n c) = Stream next' (JustS (Strict x) :*: s) (n+1) ("consS" `sArgs` c)
   where
     {-# INLINE next' #-}
-    next' (JustS (Box x) :*: s) = Yield x (NothingS :*: s)
-    next' (NothingS      :*: s) = case next s of
-                                    Yield y s' -> Yield y (NothingS :*: s')
-                                    Skip    s' -> Skip    (NothingS :*: s')
-                                    Done       -> Done
+    next' (JustS (Strict x) :*: s) = Yield x (NothingS :*: s)
+    next' (NothingS :*: s) = case next s of
+                               Yield y s' -> Yield y (NothingS :*: s')
+                               Skip    s' -> Skip    (NothingS :*: s')
+                               Done       -> Done
 
 -- | Replication
 --
@@ -81,10 +81,10 @@ replicateEachS n (Stream next s _ c) =
       case next s of
         Done -> Done
         Skip s' -> Skip (0 :*: NothingS :*: s')
-        Yield (k :*: x) s' -> Skip (k :*: JustS (Box x) :*: s')
+        Yield (k :*: x) s' -> Skip (k :*: JustS (Strict x) :*: s')
     next' (k :*: NothingS :*: s) = Done   -- FIXME: unreachable
-    next' (k :*: JustS (Box x) :*: s) =
-      Yield x (k-1 :*: JustS (Box x) :*: s)
+    next' (k :*: JustS (Strict x) :*: s) =
+      Yield x (k-1 :*: JustS (Strict x) :*: s)
 
 -- | Repeat each element in the stream n times
 --
@@ -97,9 +97,9 @@ replicateEachRS !n (Stream next s m c)
       case next s of
         Done       -> Done
         Skip    s' -> Skip (0 :*: NothingS      :*: s')
-        Yield x s' -> Skip (n :*: JustS (Box x) :*: s')
+        Yield x s' -> Skip (n :*: JustS (Strict x) :*: s')
     next' (i :*: NothingS :*: s) = Done -- unreachable
-    next' (i :*: JustS (Box x) :*: s) = Yield x (i-1 :*: JustS (Box x) :*: s)
+    next' (i :*: JustS (Strict x) :*: s) = Yield x (i-1 :*: JustS (Strict x) :*: s)
 
 -- | Concatenation
 --
index dbf0c3c..4209dc8 100644 (file)
@@ -22,7 +22,7 @@ module Data.Array.Parallel.Stream.Flat.Combinators (
 ) where
 
 import Data.Array.Parallel.Base (
-  (:*:)(..), MaybeS(..), Rebox(..), Box(..))
+  (:*:)(..), MaybeS(..), Rebox(..) )
 import Data.Array.Parallel.Base.DTrace
 import Data.Array.Parallel.Stream.Flat.Stream
 
@@ -56,20 +56,21 @@ filterS f (Stream next s n c) = Stream next' s n ("filterS" `sArgs` c)
 
 -- | Folding
 -- 
-foldS :: (b -> a -> b) -> b -> Stream a -> b
+foldS :: Rebox b => (b -> a -> b) -> b -> Stream a -> b
 {-# INLINE_STREAM foldS #-}
 foldS f z (Stream next s _ c) = traceLoopEntry c' $ fold z s
   where
     fold z s = case next s of
                  Done       -> traceLoopExit c' z
-                 Skip    s' -> s' `dseq` fold z s'
-                 Yield x s' -> s' `dseq` fold (f z x) s'
+                 Skip    s' -> z `dseq` s' `dseq` fold z s'
+                 Yield x s' -> let z' = f z x
+                               in s' `dseq` z' `dseq` fold z' s'
 
     c' = "foldS" `sArgs` c
 
 -- | Yield 'NothingS' if the 'Stream' is empty and fold it otherwise.
 --
-fold1MaybeS :: (a -> a -> a) -> Stream a -> MaybeS a
+fold1MaybeS :: Rebox a => (a -> a -> a) -> Stream a -> MaybeS a
 {-# INLINE_STREAM fold1MaybeS #-}
 fold1MaybeS f (Stream next s _ c) = traceLoopEntry c' $ fold0 s
   where
@@ -79,54 +80,55 @@ fold1MaybeS f (Stream next s _ c) = traceLoopEntry c' $ fold0 s
                   Yield x s' -> s' `dseq` fold1 x s'
     fold1 z s = case next s of
                   Done       -> traceLoopExit c' $ JustS z
-                  Skip    s' -> s' `dseq` fold1 z s'
-                  Yield x s' -> s' `dseq` fold1 (f z x) s'
+                  Skip    s' -> s' `dseq` z `dseq` fold1 z s'
+                  Yield x s' -> let z' = f z x
+                                in s' `dseq` z' `dseq` fold1 z' s'
 
     c' = "fold1MaybeS" `sArgs` c
 
 -- | Scanning
 --
-scanS :: (b -> a -> b) -> b -> Stream a -> Stream b
+scanS :: Rebox b => (b -> a -> b) -> b -> Stream a -> Stream b
 {-# INLINE_STREAM scanS #-}
-scanS f z (Stream next s n c) = Stream next' (Box z :*: s) n ("scanS" `sArgs` c)
+scanS f z (Stream next s n c) = Stream next' (z :*: s) n ("scanS" `sArgs` c)
   where
     {-# INLINE next' #-}
-    next' (Box z :*: s) = case next s of
+    next' (z :*: s) = case next s of
                         Done -> Done
-                        Skip s' -> Skip (Box z :*: s')
-                        Yield x s'  -> Yield z (Box (f z x) :*: s')
+                        Skip s' -> Skip (z :*: s')
+                        Yield x s'  -> Yield z (f z x :*: s')
 
 -- | Scan over a non-empty 'Stream'
 --
-scan1S :: (a -> a -> a) -> Stream a -> Stream a
+scan1S :: Rebox a => (a -> a -> a) -> Stream a -> Stream a
 {-# INLINE_STREAM scan1S #-}
 scan1S f (Stream next s n c) = Stream next' (NothingS :*: s) n ("scan1S" `sArgs` c)
   where
     {-# INLINE next' #-}
     next' (NothingS :*: s) =
       case next s of
-        Yield x s' -> Yield x (JustS (Box x) :*: s')
+        Yield x s' -> Yield x (JustS x :*: s')
         Skip    s' -> Skip    (NothingS :*: s')
         Done       -> Done
 
-    next' (JustS (Box z) :*: s) =
+    next' (JustS z :*: s) =
       case next s of
         Yield x s' -> let y = f z x
                       in
-                      Yield y (JustS (Box y) :*: s')
-        Skip    s' -> Skip (JustS (Box z) :*: s)
+                      Yield y (JustS y :*: s')
+        Skip    s' -> Skip (JustS z :*: s)
         Done       -> Done
 
-mapAccumS :: (acc -> a -> acc :*: b) -> acc -> Stream a -> Stream b
+mapAccumS :: Rebox acc => (acc -> a -> acc :*: b) -> acc -> Stream a -> Stream b
 {-# INLINE_STREAM mapAccumS #-}
-mapAccumS f acc (Stream step s n c) = Stream step' (s :*: Box acc) n ("mapAccumS" `sArgs` c)
+mapAccumS f acc (Stream step s n c) = Stream step' (s :*: acc) n ("mapAccumS" `sArgs` c)
   where
-    step' (s :*: Box acc) = case step s of
+    step' (s :*: acc) = case step s of
                           Done -> Done
-                          Skip s' -> Skip (s' :*: Box acc)
+                          Skip s' -> Skip (s' :*: acc)
                           Yield x s' -> let acc' :*: y = f acc x
                                         in
-                                        Yield y (s' :*: Box acc')
+                                        Yield y (s' :*: acc')
 
 
 combineS:: Stream Bool -> Stream a -> Stream a -> Stream a
index 68fdc6b..ce47fea 100644 (file)
@@ -20,34 +20,34 @@ module Data.Array.Parallel.Stream.Segmented (
 ) where
 
 import Data.Array.Parallel.Base (
-  (:*:)(..), Box(..), MaybeS(..))
+  (:*:)(..), Rebox, MaybeS(..))
 import Data.Array.Parallel.Stream.Flat (
   Step(..), Stream(..), SArgs(..))
 
-foldSS :: (a -> b -> a) -> a -> Stream Int -> Stream b -> Stream a
+foldSS :: Rebox a => (a -> b -> a) -> a -> Stream Int -> Stream b -> Stream a
 {-# INLINE_STREAM foldSS #-}
 foldSS f z (Stream nexts ss ns c1) (Stream nextv vs nv c2) =
-  Stream next (NothingS :*: Box z :*: ss :*: vs) ns ("foldSS" `sArgs` (c1,c2))
+  Stream next (NothingS :*: z :*: ss :*: vs) ns ("foldSS" `sArgs` (c1,c2))
   where
     {-# INLINE next #-}
-    next (NothingS :*: Box x :*: ss :*: vs) =
+    next (NothingS :*: x :*: ss :*: vs) =
       case nexts ss of
         Done        -> Done
-        Skip    ss' -> Skip (NothingS :*: Box x :*: ss' :*: vs)
-        Yield n ss' -> Skip (JustS n  :*: Box z :*: ss' :*: vs)
+        Skip    ss' -> Skip (NothingS :*: x :*: ss' :*: vs)
+        Yield n ss' -> Skip (JustS n  :*: z :*: ss' :*: vs)
 
-    next (JustS 0 :*: Box x :*: ss :*: vs) =
-      Yield x (NothingS :*: Box z :*: ss :*: vs)
-    next (JustS n :*: Box x :*: ss :*: vs) =
+    next (JustS 0 :*: x :*: ss :*: vs) =
+      Yield x (NothingS :*: z :*: ss :*: vs)
+    next (JustS n :*: x :*: ss :*: vs) =
       case nextv vs of
         Done        -> Done
                        -- FIXME
                        -- error
                        --  "Stream.Segmented.foldSS: invalid segment descriptor"
-        Skip    vs' -> Skip (JustS n :*: Box x :*: ss :*: vs')
-        Yield y vs' -> Skip (JustS (n-1) :*: Box (f x y) :*: ss :*: vs')
+        Skip    vs' -> Skip (JustS n :*: x :*: ss :*: vs')
+        Yield y vs' -> Skip (JustS (n-1) :*: (f x y) :*: ss :*: vs')
 
-fold1SS :: (a -> a -> a) -> Stream Int -> Stream a -> Stream a
+fold1SS :: Rebox a => (a -> a -> a) -> Stream Int -> Stream a -> Stream a
 {-# INLINE_STREAM fold1SS #-}
 fold1SS f (Stream nexts ss ns c1) (Stream nextv vs nv c2) =
   Stream next (NothingS :*: NothingS :*: ss :*: vs) ns ("fold1SS" `sArgs` (c1,c2))
@@ -63,16 +63,16 @@ fold1SS f (Stream nexts ss ns c1) (Stream nextv vs nv c2) =
       case nextv vs of
         Done        -> Done -- FIXME: error
         Skip    vs' -> Skip (JustS n     :*: NothingS      :*: ss :*: vs')
-        Yield x vs' -> Skip (JustS (n-1) :*: JustS (Box x) :*: ss :*: vs')
+        Yield x vs' -> Skip (JustS (n-1) :*: JustS x :*: ss :*: vs')
 
-    next (JustS 0 :*: JustS (Box x) :*: ss :*: vs) =
+    next (JustS 0 :*: JustS x :*: ss :*: vs) =
       Yield x (NothingS :*: NothingS :*: ss :*: vs)
 
-    next (JustS n :*: JustS (Box x) :*: ss :*: vs) =
+    next (JustS n :*: JustS x :*: ss :*: vs) =
       case nextv vs of
         Done        -> Done  -- FIXME: error
-        Skip    vs' -> Skip (JustS n     :*: JustS (Box x)        :*: ss :*: vs')
-        Yield y vs' -> Skip (JustS (n-1) :*: JustS (Box (f x  y)) :*: ss :*: vs')
+        Skip    vs' -> Skip (JustS n     :*: JustS x        :*: ss :*: vs')
+        Yield y vs' -> Skip (JustS (n-1) :*: JustS (f x  y) :*: ss :*: vs')
 
 
 combineSS:: Stream Bool -> Stream Int -> Stream a
@@ -159,17 +159,17 @@ appendSS (Stream nexts1 ss1 ns1 c1) (Stream nextv1 sv1 nv1 cv1)
                                          :*: ss1 :*: sv1 :*: ss2 :*: sv2')
 
 
-foldValuesR :: (a -> b -> a) -> a -> Int -> Int -> Stream b -> Stream a
+foldValuesR :: Rebox a => (a -> b -> a) -> a -> Int -> Int -> Stream b -> Stream a
 {-# INLINE_STREAM foldValuesR #-}
 foldValuesR f z noOfSegs segSize (Stream nextv vs nv c) =
-  Stream next (segSize :*: Box z :*: vs) noOfSegs ("foldValuesR" `sArgs` c)
+  Stream next (segSize :*: z :*: vs) noOfSegs ("foldValuesR" `sArgs` c)
   where
     {-# INLINE next #-}  
-    next (0 :*: Box x :*: vs) =
-      Yield x (segSize :*: Box z :*: vs)
+    next (0 :*: x :*: vs) =
+      Yield x (segSize :*: z :*: vs)
 
-    next (n :*: Box x :*: vs) =
+    next (n :*: x :*: vs) =
       case nextv vs of
         Done        -> Done
-        Skip    vs' -> Skip (n :*: Box x :*: vs')
-        Yield y vs' -> Skip ((n-1) :*: Box (f x y) :*: vs')
+        Skip    vs' -> Skip (n :*: x :*: vs')
+        Yield y vs' -> Skip ((n-1) :*: f x y :*: vs')
index e3e72d0..057bc04 100644 (file)
@@ -79,7 +79,7 @@ packU xs = fstU . filterU sndS . zipU xs
 
 -- |Array reduction proceeding from the left
 --
-foldlU :: UA a => (b -> a -> b) -> b -> UArr a -> b
+foldlU :: (UA a, Rebox b) => (b -> a -> b) -> b -> UArr a -> b
 {-# INLINE_U foldlU #-}
 foldlU f z xs = foldS f z (streamU xs)
 
@@ -168,7 +168,7 @@ unstreamScanM marr f z (Stream next s n c)
 --
 -- FIXME: Naming inconsistent with lists.
 --
-mapAccumLU :: (UA a, UA b) => (c -> a -> c :*: b) -> c -> UArr a -> UArr b
+mapAccumLU :: (UA a, UA b, Rebox c) => (c -> a -> c :*: b) -> c -> UArr a -> UArr b
 {-# INLINE_U mapAccumLU #-}
 mapAccumLU f z = unstreamU . mapAccumS f z . streamU
 
index 59531a3..aa44091 100644 (file)
@@ -69,7 +69,7 @@ infixl 9 `indexU`, `readMU`
 -- of an associated type.  All representation-dependent functions are methods
 -- of this class.
 --
-class HS e => UA e where
+class (HS e, Rebox e) => UA e where
   data UArr  e
   data MUArr e :: * -> *