loadArray and loadArrayWithStride are now generalized. Various syntac…

…tic improvements.
lehins · Sep 2, 2018 · 30e147e · 30e147e
1 parent cfcd4f0
commit 30e147e
Show file tree

Hide file tree

Showing 27 changed files with 461 additions and 294 deletions.
diff --git a/massiv-bench/app/Main.hs b/massiv-bench/app/Main.hs
@@ -12,6 +12,7 @@ sobelX = makeStencil (3 :. 3) (1 :. 1) $ \ f -> f (0 :. -1) * 217
 
 main :: IO ()
 main = do
-  let largeArr = makeArrayR P Seq (5 :. 5) (succ . toLinearIndex (5 :. 5))
-  let arr = computeAs P $ mapStencil (Fill 0) sobelX largeArr
-  print $ A.sum arr
+  let largeArr = makeArrayR P Par (5 :. 5) (succ . toLinearIndex (5 :. 5))
+  let arr = computeWithStrideAs P (Stride (1 :. 1)) $ mapStencil (Fill 0) sobelX largeArr
+  --let a = (# 5, 6 #)
+  print (arr ! (1 :. 1))
diff --git a/massiv-bench/bench/ConvolveSeq.hs b/massiv-bench/bench/ConvolveSeq.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE BangPatterns     #-}
+{-# LANGUAGE TypeApplications     #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GADTs            #-}
 module Main where
@@ -28,6 +29,10 @@ main = do
                 (return (computeAs U (arrDLightIx2 Seq (tupleToIx2 t2))))
                 (bench "Convolve Array Ix2" .
                  whnf (computeAs U . A.mapStencil Edge average3x3FilterConv))
+            , env
+                (return (computeAs U (arrDLightIx2 Seq (tupleToIx2 t2))))
+                (bench "Convolve with stride Array Ix2" .
+                 whnf (computeWithStrideAs U oneStride . A.mapStencil Edge average3x3FilterConv))
             , env
                 (return (computeUnboxedS (arrDLightSh2 (tupleToSh2 t2))))
                 (bench "Repa DIM2 U" .
@@ -39,6 +44,10 @@ main = do
                 (return (computeAs U (arrDLightIx2 Par (tupleToIx2 t2))))
                 (bench "Convolve Array Ix2" .
                  whnf (computeAs U . A.mapStencil Edge average3x3FilterConv))
+            , env
+                (return (computeAs U (arrDLightIx2 Par (tupleToIx2 t2))))
+                (bench "Convolve with Stride Array Ix2" .
+                 whnf (computeWithStrideAs U oneStride . A.mapStencil Edge average3x3FilterConv))
             , env
                 (return (computeUnboxedS (arrDLightSh2 (tupleToSh2 t2))))
                 (bench "Repa DIM2 U" .
@@ -85,6 +94,10 @@ main = do
                 (return (computeAs U (arrDLightIx2 Par (tupleToIx2 t2))))
                 (bench "Array Ix2 U" .
                  whnf (computeAs U . A.mapStencil Edge sobelOperator))
+            , env
+                (return (computeAs U (arrDLightIx2 Par (tupleToIx2 t2))))
+                (bench "Array with Stride Ix2 U" .
+                 whnf (computeWithStrideAs U oneStride . A.mapStencil Edge sobelOperator))
             , env
                 (return (computeUnboxedS (arrDLightSh2 (tupleToSh2 t2))))
                 (bench "Repa DIM2 U" .

diff --git a/massiv-bench/stack-ghc-8.4.yaml b/massiv-bench/stack-ghc-8.4.yaml
diff --git a/massiv-bench/stack.yaml b/massiv-bench/stack.yaml
@@ -1,9 +1,8 @@
-resolver: lts-9.20
+resolver: nightly-2018-07-05
 packages:
 - '.'
 - '../massiv/'
 extra-deps:
-- repa-3.4.1.3
-- repa-algorithms-3.4.1.2
-flags: {}
-extra-package-dbs: []
+- repa-3.4.1.2
+- repa-algorithms-3.4.1.1
+allow-newer: true
diff --git a/massiv-io/src/Graphics/ColorSpace/Elevator.hs b/massiv-io/src/Graphics/ColorSpace/Elevator.hs
@@ -177,89 +177,89 @@ instance Elevator Word where
 
 -- | Values between @[0, 127]@
 instance Elevator Int8 where
-  eToWord8 = fromIntegral . (max 0)
+  eToWord8 = fromIntegral . max 0
   {-# INLINE eToWord8 #-}
-  eToWord16 = raiseUp . (max 0)
+  eToWord16 = raiseUp . max 0
   {-# INLINE eToWord16 #-}
-  eToWord32 = raiseUp . (max 0)
+  eToWord32 = raiseUp . max 0
   {-# INLINE eToWord32 #-}
-  eToWord64 = raiseUp . (max 0)
+  eToWord64 = raiseUp . max 0
   {-# INLINE eToWord64 #-}
-  eToFloat = squashTo1 . (max 0)
+  eToFloat = squashTo1 . max 0
   {-# INLINE eToFloat #-}
-  eToDouble = squashTo1 . (max 0)
+  eToDouble = squashTo1 . max 0
   {-# INLINE eToDouble #-}
   eFromDouble = stretch . clamp01
   {-# INLINE eFromDouble #-}
 
 
 -- | Values between @[0, 32767]@
 instance Elevator Int16 where
-  eToWord8 = dropDown . (max 0)
+  eToWord8 = dropDown . max 0
   {-# INLINE eToWord8 #-}
-  eToWord16 = fromIntegral . (max 0)
+  eToWord16 = fromIntegral . max 0
   {-# INLINE eToWord16 #-}
-  eToWord32 = raiseUp . (max 0)
+  eToWord32 = raiseUp . max 0
   {-# INLINE eToWord32 #-}
-  eToWord64 = raiseUp . (max 0)
+  eToWord64 = raiseUp . max 0
   {-# INLINE eToWord64 #-}
-  eToFloat = squashTo1 . (max 0)
+  eToFloat = squashTo1 . max 0
   {-# INLINE eToFloat #-}
-  eToDouble = squashTo1 . (max 0)
+  eToDouble = squashTo1 . max 0
   {-# INLINE eToDouble #-}
   eFromDouble = stretch . clamp01
   {-# INLINE eFromDouble #-}
 
 
 -- | Values between @[0, 2147483647]@
 instance Elevator Int32 where
-  eToWord8 = dropDown . (max 0)
+  eToWord8 = dropDown . max 0
   {-# INLINE eToWord8 #-}
-  eToWord16 = dropDown . (max 0)
+  eToWord16 = dropDown . max 0
   {-# INLINE eToWord16 #-}
-  eToWord32 = fromIntegral . (max 0)
+  eToWord32 = fromIntegral . max 0
   {-# INLINE eToWord32 #-}
-  eToWord64 = raiseUp . (max 0)
+  eToWord64 = raiseUp . max 0
   {-# INLINE eToWord64 #-}
-  eToFloat = squashTo1 . (max 0)
+  eToFloat = squashTo1 . max 0
   {-# INLINE eToFloat #-}
-  eToDouble = squashTo1 . (max 0)
+  eToDouble = squashTo1 . max 0
   {-# INLINE eToDouble #-}
   eFromDouble = stretch . clamp01
   {-# INLINE eFromDouble #-}
 
 
 -- | Values between @[0, 9223372036854775807]@
 instance Elevator Int64 where
-  eToWord8 = dropDown . (max 0)
+  eToWord8 = dropDown . max 0
   {-# INLINE eToWord8 #-}
-  eToWord16 = dropDown . (max 0)
+  eToWord16 = dropDown . max 0
   {-# INLINE eToWord16 #-}
-  eToWord32 = dropDown . (max 0)
+  eToWord32 = dropDown . max 0
   {-# INLINE eToWord32 #-}
-  eToWord64 = fromIntegral . (max 0)
+  eToWord64 = fromIntegral . max 0
   {-# INLINE eToWord64 #-}
-  eToFloat = squashTo1 . (max 0)
+  eToFloat = squashTo1 . max 0
   {-# INLINE eToFloat #-}
-  eToDouble = squashTo1 . (max 0)
+  eToDouble = squashTo1 . max 0
   {-# INLINE eToDouble #-}
   eFromDouble = stretch . clamp01
   {-# INLINE eFromDouble #-}
 
 
 -- | Values between @[0, 9223372036854775807]@ on 64bit
 instance Elevator Int where
-  eToWord8 = dropDown . (max 0)
+  eToWord8 = dropDown . max 0
   {-# INLINE eToWord8 #-}
-  eToWord16 = dropDown . (max 0)
+  eToWord16 = dropDown . max 0
   {-# INLINE eToWord16 #-}
-  eToWord32 = dropDown . (max 0)
+  eToWord32 = dropDown . max 0
   {-# INLINE eToWord32 #-}
-  eToWord64 = fromIntegral . (max 0)
+  eToWord64 = fromIntegral . max 0
   {-# INLINE eToWord64 #-}
-  eToFloat = squashTo1 . (max 0)
+  eToFloat = squashTo1 . max 0
   {-# INLINE eToFloat #-}
-  eToDouble = squashTo1 . (max 0)
+  eToDouble = squashTo1 . max 0
   {-# INLINE eToDouble #-}
   eFromDouble = stretch . clamp01
   {-# INLINE eFromDouble #-}

diff --git a/massiv-io/src/Graphics/ColorSpace/Internal.hs b/massiv-io/src/Graphics/ColorSpace/Internal.hs
@@ -34,7 +34,6 @@ import           Graphics.ColorSpace.Elevator
 -- | A Pixel family with a color space and a precision of elements.
 data family Pixel cs e :: *
 
-
 class (Eq cs, Enum cs, Show cs, Bounded cs, Typeable cs,
        Functor (Pixel cs), Applicative (Pixel cs), Foldable (Pixel cs),
        Eq (Pixel cs e), VU.Unbox (Components cs e), VS.Storable (Pixel cs e), Elevator e)

diff --git a/massiv/Setup.hs b/massiv/Setup.hs
@@ -1,2 +1,3 @@
 import Distribution.Simple
+main :: IO ()
 main = defaultMain
diff --git a/massiv/src/Data/Massiv/Array.hs b/massiv/src/Data/Massiv/Array.hs
@@ -78,6 +78,8 @@ module Data.Massiv.Array
   , computeAs
   , computeProxy
   , computeSource
+  , computeWithStride
+  , computeWithStrideAs
   , clone
   , convert
   , convertAs

diff --git a/massiv/src/Data/Massiv/Array/Delayed.hs b/massiv/src/Data/Massiv/Array/Delayed.hs
@@ -14,8 +14,6 @@ module Data.Massiv.Array.Delayed
   , fromInterleaved
   , DW(..)
   , Window(..)
-  , getStride
-  , setStride
   , getWindow
   , makeWindowedArray
   ) where

diff --git a/massiv/src/Data/Massiv/Array/Delayed/Interleaved.hs b/massiv/src/Data/Massiv/Array/Delayed/Interleaved.hs
@@ -59,13 +59,27 @@ instance Index ix => Load DI ix e where
   loadS (DIArray arr) = loadS arr
   {-# INLINE loadS #-}
   loadP wIds (DIArray (DArray _ sz f)) _ unsafeWrite =
-    withScheduler_ wIds $ \ scheduler -> do
+    withScheduler_ wIds $ \scheduler -> do
       let !totalLength = totalElem sz
       loopM_ 0 (< numWorkers scheduler) (+ 1) $ \ !start ->
         scheduleWork scheduler $
         iterLinearM_ sz start totalLength (numWorkers scheduler) (<) $ \ !k !ix ->
           unsafeWrite k $ f ix
   {-# INLINE loadP #-}
+  loadArray (DIArray (DArray _ sz f)) numWorkers' scheduleWork' _ unsafeWrite =
+    loopM_ 0 (< numWorkers') (+ 1) $ \ !start ->
+      scheduleWork' $
+      iterLinearM_ sz start (totalElem sz) numWorkers' (<) $ \ !k -> unsafeWrite k . f
+  {-# INLINE loadArray #-}
+  loadArrayWithStride stride resultSize arr numWorkers' scheduleWork' _ unsafeWrite =
+    let strideIx = unStride stride
+        DIArray (DArray _ _ f) = arr
+    in loopM_ 0 (< numWorkers') (+ 1) $ \ !start ->
+          scheduleWork' $
+          iterLinearM_ resultSize start (totalElem resultSize) numWorkers' (<) $
+            \ !i ix -> unsafeWrite i (f (liftIndex2 (*) strideIx ix))
+  --(DIArray darr) = loadArrayWithStride stride resultSize darr
+  {-# INLINE loadArrayWithStride #-}
 
 -- | Convert a source array into an array that, when computed, will have its elemets evaluated out
 -- of order (interleaved amoungs cores), hence making unbalanced computation better parallelizable.

diff --git a/massiv/src/Data/Massiv/Array/Delayed/Internal.hs b/massiv/src/Data/Massiv/Array/Delayed/Internal.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE BangPatterns          #-}
 {-# LANGUAGE CPP                   #-}
 {-# LANGUAGE FlexibleContexts      #-}
@@ -140,20 +142,72 @@ instance Index ix => Foldable (Array D ix) where
   {-# INLINE toList #-}
 
 
+-- divideRectangular numWorkers' scheduleWork' sz f = do
+--   let k = headDim sz
+--       (chunkHeight, slackHeight) = k `quotRem` numWorkers'
+--     loopM_ 0 (< numWorkers') (+ 1) $ \ !wid ->
+--       let !it' = wid * chunkHeight + it
+--        in loadWindow (it' :. (it' + chunkHeight))
+--     when (slackHeight > 0) $
+--       let !itSlack = numWorkers' * chunkHeight + it
+--        in loadWindow (itSlack :. (itSlack + slackHeight))
+
+-- loadArrayWithStrideIx2 ::
+--      Monad m
+--   => Stride Ix2
+--   -> Ix2
+--   -> Array DW Ix2 e
+--   -> (m () -> m ())
+--   -> (Int -> e -> m ())
+--   -> m (Ix2 -> m (), Ix2)
+-- loadArrayWithStrideIx2 stride sz arr numWorkers' scheduleWork' unsafeWrite = do
+--   let DArray _ (m :. n) indexB = arr
+--       strideIx@(is :. js) = unStride stride
+--       writeB !ix = unsafeWrite (toLinearIndexStride stride sz ix) (indexB ix)
+--       {-# INLINE writeB #-}
+--       load !(it :. ib) =
+--         scheduleWork' $ iterM_ (strideStart stride (it :. 0)) (ib :. n) strideIx (<) writeB
+--       {-# INLINE load #-}
+--   let !(chunkHeight, slackHeight) = m `quotRem` numWorkers'
+--   loopM_ 0 (< numWorkers') (+ 1) $ \ !wid ->
+--     let !it' = wid * chunkHeight + it
+--      in load (it' :. (it' + chunkHeight))
+--   when (slackHeight > 0) $
+--     let !itSlack = numWorkers' * chunkHeight + it
+--      in load (itSlack :. (itSlack + slackHeight))
+-- {-# INLINE loadArrayWithIx2 #-}
+
+-- instance {-# OVERLAPPING #-} Load D Ix1 e where
+--   loadS (DArray _ sz f) _ unsafeWrite =
+--     iterM_ zeroIndex sz (pureIndex 1) (<) $ \ !ix -> unsafeWrite (toLinearIndex sz ix) (f ix)
+--   {-# INLINE loadS #-}
+--   loadP wIds (DArray _ sz f) _ unsafeWrite = do
+--     divideWork_ wIds sz $ \ !scheduler !chunkLength !totalLength !slackStart -> do
+--       loopM_ 0 (< slackStart) (+ chunkLength) $ \ !start ->
+--         scheduleWork scheduler $
+--         iterLinearM_ sz start (start + chunkLength) 1 (<) $ \ !k !ix -> unsafeWrite k (f ix)
+--       scheduleWork scheduler $
+--         iterLinearM_ sz slackStart totalLength 1 (<) $ \ !k !ix -> unsafeWrite k (f ix)
+--   {-# INLINE loadP #-}
+--   loadArray (DArray _ sz f) numWorkers' scheduleWork' _ =
+--     splitLinearlyWith_ numWorkers' scheduleWork' sz f
+--   {-# INLINE loadArray #-}
+--   -- loadArrayWithStride stride resultSize (DArray _ sz f) numWorkers' scheduleWork' _ =
+--   --   splitLinearlyWith_ numWorkers' scheduleWork' sz f
+--   -- {-# INLINE loadArrayWithStride #-}
+
+
 instance Index ix => Load D ix e where
   loadS (DArray _ sz f) _ unsafeWrite =
-    iterM_ zeroIndex sz (pureIndex 1) (<) $ \ !ix ->
-      unsafeWrite (toLinearIndex sz ix) (f ix)
+    iterM_ zeroIndex sz (pureIndex 1) (<) $ \ !ix -> unsafeWrite (toLinearIndex sz ix) (f ix)
   {-# INLINE loadS #-}
-  loadP wIds (DArray _ sz f) _ unsafeWrite = do
+  loadP wIds (DArray _ sz f) _ unsafeWrite =
     divideWork_ wIds sz $ \ !scheduler !chunkLength !totalLength !slackStart -> do
       loopM_ 0 (< slackStart) (+ chunkLength) $ \ !start ->
         scheduleWork scheduler $
-        iterLinearM_ sz start (start + chunkLength) 1 (<) $ \ !k !ix -> do
-          unsafeWrite k (f ix)
+        iterLinearM_ sz start (start + chunkLength) 1 (<) $ \ !k !ix -> unsafeWrite k (f ix)
       scheduleWork scheduler $
-        iterLinearM_ sz slackStart totalLength 1 (<) $ \ !k !ix -> do
-          unsafeWrite k (f ix)
+        iterLinearM_ sz slackStart totalLength 1 (<) $ \ !k !ix -> unsafeWrite k (f ix)
   {-# INLINE loadP #-}