diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,3 @@ import Distribution.Simple +main :: IO () main = defaultMain diff --git a/include/massiv.h b/include/massiv.h new file mode 100644 --- /dev/null +++ b/include/massiv.h @@ -0,0 +1,11 @@ +#ifndef MASSIV_INCLUDE + +#define MASSIV_INCLUDE + +#if MASSIV_UNSAFE_CHECKS +#define INDEX_CHECK(name, s, f) (indexWith __FILE__ __LINE__ (name) (s) (f)) +#else +#define INDEX_CHECK(name, s, f) ((f)) +#endif + +#endif diff --git a/massiv.cabal b/massiv.cabal --- a/massiv.cabal +++ b/massiv.cabal @@ -1,5 +1,5 @@ name: massiv -version: 0.2.0.0 +version: 0.2.1.0 synopsis: Massiv (Массив) is an Array Library. description: Multi-dimensional Arrays with fusion, stencils and parallel computation. homepage: https://github.com/lehins/massiv @@ -13,6 +13,12 @@ extra-source-files: README.md cabal-version: >=1.10 +flag unsafe-checks + description: Enable all the bounds checks for unsafe functions at the cost of + significant performance penalty + default: False + manual: True + library hs-source-dirs: src exposed-modules: Data.Massiv.Array @@ -31,8 +37,7 @@ other-modules: Data.Massiv.Array.Delayed.Internal , Data.Massiv.Array.Delayed.Interleaved , Data.Massiv.Array.Delayed.Windowed - , Data.Massiv.Array.Manifest.BoxedNF - , Data.Massiv.Array.Manifest.BoxedStrict + , Data.Massiv.Array.Manifest.Boxed , Data.Massiv.Array.Manifest.Internal , Data.Massiv.Array.Manifest.List , Data.Massiv.Array.Manifest.Primitive @@ -50,15 +55,22 @@ , Data.Massiv.Core.Computation , Data.Massiv.Core.Index.Class , Data.Massiv.Core.Index.Ix + , Data.Massiv.Core.Index.Stride , Data.Massiv.Core.Iterator , Data.Massiv.Core.List build-depends: base >= 4.8 && < 5 + , bytestring , data-default-class , deepseq , ghc-prim , primitive , vector + include-dirs: include + install-includes: massiv.h + if flag(unsafe-checks) + cpp-options: -DMASSIV_UNSAFE_CHECKS + if impl(ghc < 8.0) build-depends: semigroups if impl(ghc < 7.10) @@ -73,6 +85,8 @@ hs-source-dirs: tests main-is: Spec.hs other-modules: Data.Massiv.Array.DelayedSpec + , Data.Massiv.Array.Delayed.WindowedSpec + , Data.Massiv.Array.ManifestSpec , Data.Massiv.Array.Manifest.VectorSpec --, Data.Massiv.Array.MutableSpec , Data.Massiv.Array.Ops.ConstructSpec @@ -84,6 +98,7 @@ , Data.Massiv.Core.IndexSpec , Data.Massiv.Core.SchedulerSpec build-depends: base >= 4.8 && < 5 + , bytestring , deepseq , data-default , safe-exceptions diff --git a/src/Data/Massiv/Array.hs b/src/Data/Massiv/Array.hs --- a/src/Data/Massiv/Array.hs +++ b/src/Data/Massiv/Array.hs @@ -78,6 +78,8 @@ , computeAs , computeProxy , computeSource + , computeWithStride + , computeWithStrideAs , clone , convert , convertAs @@ -122,7 +124,7 @@ , module Data.Massiv.Array.Numeric ) where -import Data.Massiv.Array.Delayed hiding (unsafeBackpermuteDW) +import Data.Massiv.Array.Delayed import Data.Massiv.Array.Manifest import Data.Massiv.Array.Manifest.Internal import Data.Massiv.Array.Manifest.List diff --git a/src/Data/Massiv/Array/Delayed.hs b/src/Data/Massiv/Array/Delayed.hs --- a/src/Data/Massiv/Array/Delayed.hs +++ b/src/Data/Massiv/Array/Delayed.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -- | -- Module : Data.Massiv.Array.Delayed -- Copyright : (c) Alexey Kuleshevich 2018 @@ -14,9 +11,11 @@ , delay , DI(..) , toInterleaved + , fromInterleaved , DW(..) + , Window(..) + , getWindow , makeWindowedArray - , unsafeBackpermuteDW ) where import Data.Massiv.Array.Delayed.Interleaved diff --git a/src/Data/Massiv/Array/Delayed/Interleaved.hs b/src/Data/Massiv/Array/Delayed/Interleaved.hs --- a/src/Data/Massiv/Array/Delayed/Interleaved.hs +++ b/src/Data/Massiv/Array/Delayed/Interleaved.hs @@ -15,6 +15,7 @@ module Data.Massiv.Array.Delayed.Interleaved ( DI(..) , toInterleaved + , fromInterleaved ) where import Data.Massiv.Array.Delayed.Internal @@ -28,13 +29,13 @@ type instance EltRepr DI ix = DI -newtype instance Array DI ix e = DIArray { idArray :: (Array D ix e) } +newtype instance Array DI ix e = DIArray { diArray :: Array D ix e } instance Index ix => Construct DI ix e where - getComp = dComp . idArray + getComp = dComp . diArray {-# INLINE getComp #-} - setComp c arr = arr { idArray = (idArray arr) { dComp = c } } + setComp c arr = arr { diArray = (diArray arr) { dComp = c } } {-# INLINE setComp #-} unsafeMakeArray c sz = DIArray . unsafeMakeArray c sz @@ -47,27 +48,47 @@ size (DIArray arr) = size arr {-# INLINE size #-} - unsafeResize sz = DIArray . unsafeResize sz . idArray + unsafeResize sz = DIArray . unsafeResize sz . diArray {-# INLINE unsafeResize #-} - unsafeExtract sIx newSz = DIArray . unsafeExtract sIx newSz . idArray + unsafeExtract sIx newSz = DIArray . unsafeExtract sIx newSz . diArray {-# INLINE unsafeExtract #-} instance Index ix => Load DI ix e where - loadS (DIArray arr) unsafeRead unsafeWrite = loadS arr unsafeRead unsafeWrite + 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 numWorkers' scheduleWork' (DIArray (DArray _ sz f)) _ unsafeWrite = + loopM_ 0 (< numWorkers') (+ 1) $ \ !start -> + scheduleWork' $ + iterLinearM_ sz start (totalElem sz) numWorkers' (<) $ \ !k -> unsafeWrite k . f + {-# INLINE loadArray #-} + loadArrayWithStride numWorkers' scheduleWork' stride resultSize arr _ 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)) + {-# 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. toInterleaved :: Source r ix e => Array r ix e -> Array DI ix e toInterleaved = DIArray . delay {-# INLINE toInterleaved #-} + +-- | /O(1)/ - Unwrap the interleved array. +-- +-- @since 0.2.1 +fromInterleaved :: Array DI ix e -> Array D ix e +fromInterleaved = diArray +{-# INLINE fromInterleaved #-} diff --git a/src/Data/Massiv/Array/Delayed/Internal.hs b/src/Data/Massiv/Array/Delayed/Internal.hs --- a/src/Data/Massiv/Array/Delayed/Internal.hs +++ b/src/Data/Massiv/Array/Delayed/Internal.hs @@ -1,9 +1,13 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} -- | -- Module : Data.Massiv.Array.Delayed.Internal -- Copyright : (c) Alexey Kuleshevich 2018 @@ -22,21 +26,23 @@ , liftArray2 ) where -import Data.Foldable (Foldable (..)) +import Data.Foldable (Foldable (..)) import Data.Massiv.Array.Ops.Fold.Internal as A import Data.Massiv.Core.Common import Data.Massiv.Core.Scheduler -import Data.Monoid ((<>)) -import GHC.Base (build) -import Prelude hiding (zipWith) +import Data.Monoid ((<>)) +import GHC.Base (build) +import Prelude hiding (zipWith) +#include "massiv.h" + -- | Delayed representation. data D = D deriving Show data instance Array D ix e = DArray { dComp :: !Comp , dSize :: !ix - , dUnsafeIndex :: ix -> e } + , dIndex :: ix -> e } type instance EltRepr D ix = D instance Index ix => Construct D ix e where @@ -51,7 +57,7 @@ instance Index ix => Source D ix e where - unsafeIndex = dUnsafeIndex + unsafeIndex = INDEX_CHECK("(Source D ix e).unsafeIndex", size, dIndex) {-# INLINE unsafeIndex #-} instance Index ix => Size D ix e where @@ -138,18 +144,15 @@ 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 #-} diff --git a/src/Data/Massiv/Array/Delayed/Windowed.hs b/src/Data/Massiv/Array/Delayed/Windowed.hs --- a/src/Data/Massiv/Array/Delayed/Windowed.hs +++ b/src/Data/Massiv/Array/Delayed/Windowed.hs @@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} @@ -16,35 +17,46 @@ module Data.Massiv.Array.Delayed.Windowed ( DW(..) , Array(..) + , Window(..) + , getWindow , makeWindowedArray - , unsafeBackpermuteDW ) where -import Control.Monad (when) +import Control.Monad (when) import Data.Massiv.Array.Delayed.Internal -import Data.Massiv.Array.Manifest.BoxedStrict +import Data.Massiv.Array.Manifest.Boxed import Data.Massiv.Array.Manifest.Internal import Data.Massiv.Core import Data.Massiv.Core.Common -import Data.Massiv.Core.List (showArray) +import Data.Massiv.Core.List (showArray) import Data.Massiv.Core.Scheduler -import Data.Proxy (Proxy (..)) -import Data.Typeable (showsTypeRep, typeRep) +import Data.Maybe (fromMaybe) +import Data.Proxy (Proxy (..)) +import Data.Typeable (showsTypeRep, typeRep) -- | Delayed Windowed Array representation. data DW = DW type instance EltRepr DW ix = D -data instance Array DW ix e = DWArray { wdArray :: !(Array D ix e) - , wdStencilSize :: Maybe ix +data Window ix e = Window { windowStart :: !ix + -- ^ Index of where window will start at. + , windowSize :: !ix + -- ^ Size of the window + , windowIndex :: ix -> e + -- ^ Indexing function for the window + } + +instance Functor (Window ix) where + fmap f arr@Window{windowIndex} = arr { windowIndex = f . windowIndex } + +data instance Array DW ix e = DWArray { dwArray :: !(Array D ix e) + , dwStencilSize :: !(Maybe ix) -- ^ Setting this value during stencil -- application improves cache utilization -- while computing an array - , wdWindowStartIndex :: !ix - , wdWindowSize :: !ix - , wdWindowUnsafeIndex :: ix -> e } - + , dwWindow :: !(Maybe (Window ix e)) + } instance {-# OVERLAPPING #-} (Show e, Ragged L ix e, Load DW ix e) => Show (Array DW ix e) where @@ -52,37 +64,33 @@ instance Index ix => Construct DW ix e where - getComp = dComp . wdArray + getComp = dComp . dwArray {-# INLINE getComp #-} - setComp c arr = arr { wdArray = (wdArray arr) { dComp = c } } + setComp c arr = arr { dwArray = (dwArray arr) { dComp = c } } {-# INLINE setComp #-} - unsafeMakeArray c sz f = DWArray (unsafeMakeArray c sz f) Nothing zeroIndex zeroIndex f + unsafeMakeArray c sz f = + DWArray (unsafeMakeArray c sz f) Nothing Nothing {-# INLINE unsafeMakeArray #-} --- | Any resize or extract on Windowed Array will hurt the performance. +-- | Any resize or extract on Windowed Array will loose the interior window and all other +-- optimizations, thus hurting the performance a lot. instance Index ix => Size DW ix e where - size = size . wdArray + size = dSize . dwArray {-# INLINE size #-} - unsafeResize sz DWArray {..} = - let dArr = unsafeResize sz wdArray - in DWArray - { wdArray = dArr - , wdStencilSize = Nothing - , wdWindowStartIndex = zeroIndex - , wdWindowSize = zeroIndex - , wdWindowUnsafeIndex = evaluateAt dArr - } - unsafeExtract sIx newSz = unsafeExtract sIx newSz . wdArray + unsafeResize sz arr = arr { dwArray = unsafeResize sz (dwArray arr) + , dwWindow = Nothing + , dwStencilSize = Nothing } + unsafeExtract sIx newSz = unsafeExtract sIx newSz . dwArray instance Functor (Array DW ix) where - fmap f !arr = + fmap f arr@DWArray{dwArray, dwWindow} = arr - { wdArray = fmap f (wdArray arr) - , wdWindowUnsafeIndex = f . wdWindowUnsafeIndex arr + { dwArray = fmap f dwArray + , dwWindow = fmap f <$> dwWindow } {-# INLINE fmap #-} @@ -99,227 +107,334 @@ -> ix -- ^ Size of the window -> (ix -> e) -- ^ Inside window indexing function -> Array DW ix e -makeWindowedArray !arr !wIx !wSz wUnsafeIndex - | not (isSafeIndex sz wIx) = +makeWindowedArray !arr !windowStart !windowSize windowIndex + | not (isSafeIndex sz windowStart) = error $ - "Incorrect window starting index: " ++ show wIx ++ " for: " ++ show (size arr) - | liftIndex2 (+) wIx wSz > sz = + "makeWindowedArray: Incorrect window starting index: (" ++ + show windowStart ++ ") for array size: (" ++ show (size arr) ++ ")" + | totalElem windowSize == 0 = error $ - "Incorrect window size: " ++ - show wSz ++ " and/or placement: " ++ show wIx ++ " for: " ++ show (size arr) + "makeWindowedArray: Window can't hold any elements with this size: (" ++ show windowSize ++ ")" + | not (isSafeIndex (liftIndex (+ 1) sz) (liftIndex2 (+) windowStart windowSize)) = + error $ + "makeWindowedArray: Incorrect window size: (" ++ + show windowSize ++ + ") and/or starting index: (" ++ + show windowStart ++ ") for array size: (" ++ show (size arr) ++ ")" | otherwise = DWArray - { wdArray = delay arr - , wdStencilSize = Nothing - , wdWindowStartIndex = wIx - , wdWindowSize = wSz - , wdWindowUnsafeIndex = wUnsafeIndex - } - where sz = size arr + { dwArray = delay arr + , dwStencilSize = Nothing + , dwWindow = Just $! Window {..} + } + where + sz = size arr {-# INLINE makeWindowedArray #-} --- | Backpermute a windowed array. If index mappings aren't correct reading memory out of bounds is --- very likely. --- --- __Note__: windowStartIndex is mapped to the new windowStartIndex using the "old to new index" --- map. This means that the order of the elements should be preserved, or performance will take a --- major hit. --- --- __Important__: This function is still experimental and can be removed in any future minor --- release. +-- | Get the `Window` from the Windowed array. -- --- @since 0.2.0 -unsafeBackpermuteDW :: - Index ix - => (ix -> ix) -- ^ map from old to new index - -> (ix -> ix) -- ^ map from new to old index - -> ix -- ^ Size of resulting array - -> Array DW ix a - -> Array DW ix a -unsafeBackpermuteDW toNewIndex toOldIndex sz DWArray {..} = - DWArray - { wdArray = - DArray {dComp = dComp wdArray, dSize = sz, dUnsafeIndex = dUnsafeIndex wdArray . toOldIndex} - , wdStencilSize = wdStencilSize - , wdWindowStartIndex = newWindowStartIndex - , wdWindowSize = - liftIndex2 - (-) - (toNewIndex (liftIndex2 (+) wdWindowStartIndex wdWindowSize)) - newWindowStartIndex - , wdWindowUnsafeIndex = wdWindowUnsafeIndex . toOldIndex - } - where - !newWindowStartIndex = toNewIndex wdWindowStartIndex -{-# INLINE unsafeBackpermuteDW #-} +-- @since 0.2.1 +getWindow :: Array DW ix e -> Maybe (Window ix e) +getWindow = dwWindow +{-# INLINE getWindow #-} +zeroWindow :: Index ix => Window ix e +zeroWindow = Window zeroIndex zeroIndex windowError +{-# INLINE zeroWindow #-} + +windowError :: a +windowError = error "Impossible: index of zeroWindow" +{-# NOINLINE windowError #-} + + +loadWithIx1 :: + (Monad m) + => (m () -> m ()) + -> Array DW Ix1 e + -> (Ix1 -> e -> m a) + -> m ((Ix1, Ix1) -> m (), (Ix1, Ix1)) +loadWithIx1 with (DWArray (DArray _ sz indexB) _ window) unsafeWrite = do + let Window it wk indexW = fromMaybe zeroWindow window + wEnd = it + wk + with $ iterM_ 0 it 1 (<) $ \ !i -> unsafeWrite i (indexB i) + with $ iterM_ wEnd sz 1 (<) $ \ !i -> unsafeWrite i (indexB i) + return (\(from, to) -> with $ iterM_ from to 1 (<) $ \ !i -> unsafeWrite i (indexW i), (it, wEnd)) +{-# INLINE loadWithIx1 #-} + + instance {-# OVERLAPPING #-} Load DW Ix1 e where - loadS (DWArray (DArray _ sz indexB) _ it wk indexW) _ unsafeWrite = do - iterM_ 0 it (pureIndex 1) (<) $ \ !i -> unsafeWrite i (indexB i) - iterM_ it wk (pureIndex 1) (<) $ \ !i -> unsafeWrite i (indexW i) - iterM_ wk sz (pureIndex 1) (<) $ \ !i -> unsafeWrite i (indexB i) + loadS arr _ unsafeWrite = loadWithIx1 id arr unsafeWrite >>= uncurry ($) {-# INLINE loadS #-} - loadP wIds (DWArray (DArray _ sz indexB) _ it wk indexW) _ unsafeWrite = do - divideWork_ wIds wk $ \ !scheduler !chunkLength !totalLength !slackStart -> do - scheduleWork scheduler $ - iterM_ 0 it (pureIndex 1) (<) $ \ !ix -> - unsafeWrite (toLinearIndex sz ix) (indexB ix) - scheduleWork scheduler $ - iterM_ wk sz (pureIndex 1) (<) $ \ !ix -> - unsafeWrite (toLinearIndex sz ix) (indexB ix) - loopM_ it (< (slackStart + it)) (+ chunkLength) $ \ !start -> - scheduleWork scheduler $ - iterM_ start (start + chunkLength) (pureIndex 1) (<) $ \ !k -> - unsafeWrite k $ indexW k - scheduleWork scheduler $ - iterM_ (slackStart + it) (totalLength + it) (pureIndex 1) (<) $ \ !k -> - unsafeWrite k (indexW k) + loadP wIds arr _ unsafeWrite = + withScheduler_ wIds $ \scheduler -> do + (loadWindow, (wStart, wEnd)) <- loadWithIx1 (scheduleWork scheduler) arr unsafeWrite + let (chunkHeight, slackHeight) = (wEnd - wStart) `quotRem` numWorkers scheduler + loopM_ 0 (< numWorkers scheduler) (+ 1) $ \ !wid -> + let !it' = wid * chunkHeight + wStart + in loadWindow (it', it' + chunkHeight) + when (slackHeight > 0) $ + let !itSlack = numWorkers scheduler * chunkHeight + wStart + in loadWindow (itSlack, itSlack + slackHeight) {-# INLINE loadP #-} + loadArray numWorkers' scheduleWork' arr = + loadArrayWithStride numWorkers' scheduleWork' oneStride (size arr) arr + {-# INLINE loadArray #-} + loadArrayWithStride numWorkers' scheduleWork' stride sz arr _ unsafeWrite = do + (loadWindow, (wStart, wEnd)) <- loadArrayWithIx1 scheduleWork' arr stride sz unsafeWrite + let (chunkHeight, slackHeight) = (wEnd - wStart) `quotRem` numWorkers' + loopM_ 0 (< numWorkers') (+ 1) $ \ !wid -> + let !it' = wid * chunkHeight + wStart + in loadWindow (it', it' + chunkHeight) + when (slackHeight > 0) $ + let !itSlack = numWorkers' * chunkHeight + wStart + in loadWindow (itSlack, itSlack + slackHeight) + {-# INLINE loadArrayWithStride #-} +loadArrayWithIx1 :: + (Monad m) + => (m () -> m ()) + -> Array DW Ix1 e + -> Stride Ix1 + -> Ix1 + -> (Ix1 -> e -> m a) + -> m ((Ix1, Ix1) -> m (), (Ix1, Ix1)) +loadArrayWithIx1 with (DWArray (DArray _ arrSz indexB) _ window) stride _ unsafeWrite = do + let Window it wk indexW = fromMaybe zeroWindow window + wEnd = it + wk + strideIx = unStride stride + with $ iterM_ 0 it strideIx (<) $ \ !i -> unsafeWrite (i `div` strideIx) (indexB i) + with $ + iterM_ (strideStart stride wEnd) arrSz strideIx (<) $ \ !i -> + unsafeWrite (i `div` strideIx) (indexB i) + return + ( \(from, to) -> + with $ + iterM_ (strideStart stride from) to strideIx (<) $ \ !i -> + unsafeWrite (i `div` strideIx) (indexW i) + , (it, wEnd)) +{-# INLINE loadArrayWithIx1 #-} + +loadWithIx2 :: + Monad m + => (m () -> m ()) + -> Array DW Ix2 t1 + -> (Int -> t1 -> m ()) + -> m (Ix2 -> m (), Ix2) +loadWithIx2 with arr unsafeWrite = do + let DWArray (DArray _ (m :. n) indexB) mStencilSize window = arr + let Window (it :. jt) (wm :. wn) indexW = fromMaybe zeroWindow window + let ib :. jb = (wm + it) :. (wn + jt) + !blockHeight = + case mStencilSize of + Just (i :. _) -> min (max 1 i) 7 + _ -> 1 + stride = oneStride + !sz = strideSize stride $ size arr + writeB !ix = unsafeWrite (toLinearIndex sz ix) (indexB ix) + {-# INLINE writeB #-} + writeW !ix = unsafeWrite (toLinearIndex sz ix) (indexW ix) + {-# INLINE writeW #-} + with $ iterM_ (0 :. 0) (it :. n) (1 :. 1) (<) writeB + with $ iterM_ (ib :. 0) (m :. n) (1 :. 1) (<) writeB + with $ iterM_ (it :. 0) (ib :. jt) (1 :. 1) (<) writeB + with $ iterM_ (it :. jb) (ib :. n) (1 :. 1) (<) writeB + let f (it' :. ib') = with $ unrollAndJam blockHeight (it' :. jt) (ib' :. jb) 1 writeW + {-# INLINE f #-} + return (f, it :. ib) +{-# INLINE loadWithIx2 #-} + + instance {-# OVERLAPPING #-} Load DW Ix2 e where - loadS arr _ unsafeWrite = do - let (DWArray (DArray _ sz@(m :. n) indexB) mStencilSz (it :. jt) (wm :. wn) indexW) = - arr - let (ib :. jb) = (wm + it) :. (wn + jt) - blockHeight = case mStencilSz of - Just (i :. _) -> i - _ -> 1 - iterM_ (0 :. 0) (it :. n) (pureIndex 1) (<) $ \ !ix -> - unsafeWrite (toLinearIndex sz ix) (indexB ix) - iterM_ (ib :. 0) (m :. n) (pureIndex 1) (<) $ \ !ix -> - unsafeWrite (toLinearIndex sz ix) (indexB ix) - iterM_ (it :. 0) (ib :. jt) (pureIndex 1) (<) $ \ !ix -> - unsafeWrite (toLinearIndex sz ix) (indexB ix) - iterM_ (it :. jb) (ib :. n) (pureIndex 1) (<) $ \ !ix -> - unsafeWrite (toLinearIndex sz ix) (indexB ix) - unrollAndJam blockHeight (it :. ib) (jt :. jb) $ \ !ix -> - unsafeWrite (toLinearIndex sz ix) (indexW ix) + loadS arr _ unsafeWrite = loadWithIx2 id arr unsafeWrite >>= uncurry ($) {-# INLINE loadS #-} - loadP wIds arr _ unsafeWrite = do - let (DWArray (DArray _ sz@(m :. n) indexB) mStencilSz (it :. jt) (wm :. wn) indexW) = arr + -- + loadP wIds arr _ unsafeWrite = withScheduler_ wIds $ \scheduler -> do - let (ib :. jb) = (wm + it) :. (wn + jt) - !blockHeight = case mStencilSz of - Just (i :. _) -> i - _ -> 1 - !(chunkHeight, slackHeight) = wm `quotRem` numWorkers scheduler - let loadBlock !it' !ib' = - unrollAndJam blockHeight (it' :. ib') (jt :. jb) $ \ !ix -> - unsafeWrite (toLinearIndex sz ix) (indexW ix) - {-# INLINE loadBlock #-} - scheduleWork scheduler $ - iterM_ (0 :. 0) (it :. n) (pureIndex 1) (<) $ \ !ix -> - unsafeWrite (toLinearIndex sz ix) (indexB ix) - scheduleWork scheduler $ - iterM_ (ib :. 0) (m :. n) (pureIndex 1) (<) $ \ !ix -> - unsafeWrite (toLinearIndex sz ix) (indexB ix) - scheduleWork scheduler $ - iterM_ (it :. 0) (ib :. jt) (pureIndex 1) (<) $ \ !ix -> - unsafeWrite (toLinearIndex sz ix) (indexB ix) - scheduleWork scheduler $ - iterM_ (it :. jb) (ib :. n) (pureIndex 1) (<) $ \ !ix -> - unsafeWrite (toLinearIndex sz ix) (indexB ix) - loopM_ 0 (< numWorkers scheduler) (+ 1) $ \ !wid -> do + (loadWindow, it :. ib) <- loadWithIx2 (scheduleWork scheduler) arr unsafeWrite + let !(chunkHeight, slackHeight) = (ib - it) `quotRem` numWorkers scheduler + loopM_ 0 (< numWorkers scheduler) (+ 1) $ \ !wid -> let !it' = wid * chunkHeight + it - scheduleWork scheduler $ loadBlock it' (it' + chunkHeight) - when (slackHeight > 0) $ do - let !itSlack = (numWorkers scheduler) * chunkHeight + it - scheduleWork scheduler $ - loadBlock itSlack (itSlack + slackHeight) + in loadWindow (it' :. (it' + chunkHeight)) + when (slackHeight > 0) $ + let !itSlack = numWorkers scheduler * chunkHeight + it + in loadWindow (itSlack :. (itSlack + slackHeight)) {-# INLINE loadP #-} + loadArray numWorkers' scheduleWork' arr = + loadArrayWithStride numWorkers' scheduleWork' oneStride (size arr) arr + {-# INLINE loadArray #-} + loadArrayWithStride numWorkers' scheduleWork' stride sz arr _ unsafeWrite = do + (loadWindow, it :. ib) <- loadArrayWithIx2 scheduleWork' arr stride sz unsafeWrite + let !(chunkHeight, slackHeight) = (ib - it) `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)) + {-# INLINE loadArrayWithStride #-} +loadArrayWithIx2 :: + Monad m + => (m () -> m ()) + -> Array DW Ix2 e + -> Stride Ix2 + -> Ix2 + -> (Int -> e -> m ()) + -> m (Ix2 -> m (), Ix2) +loadArrayWithIx2 with arr stride sz unsafeWrite = do + let DWArray (DArray _ (m :. n) indexB) mStencilSize window = arr + let Window (it :. jt) (wm :. wn) indexW = fromMaybe zeroWindow window + let ib :. jb = (wm + it) :. (wn + jt) + !blockHeight = + case mStencilSize of + Just (i :. _) -> min (max 1 i) 7 + _ -> 1 + strideIx@(is :. js) = unStride stride + writeB !ix = unsafeWrite (toLinearIndexStride stride sz ix) (indexB ix) + {-# INLINE writeB #-} + writeW !ix = unsafeWrite (toLinearIndexStride stride sz ix) (indexW ix) + {-# INLINE writeW #-} + with $ iterM_ (0 :. 0) (it :. n) strideIx (<) writeB + with $ iterM_ (strideStart stride (ib :. 0)) (m :. n) strideIx (<) writeB + with $ iterM_ (strideStart stride (it :. 0)) (ib :. jt) strideIx (<) writeB + with $ iterM_ (strideStart stride (it :. jb)) (ib :. n) strideIx (<) writeB + f <- + if is > 1 -- Turn off unrolling for vertical strides + then return $ \(it' :. ib') -> + iterM_ (strideStart stride (it' :. jt)) (ib' :. jb) strideIx (<) writeW + else return $ \(it' :. ib') -> + unrollAndJam blockHeight (strideStart stride (it' :. jt)) (ib' :. jb) js writeW + return (f, it :. ib) +{-# INLINE loadArrayWithIx2 #-} --- instance {-# OVERLAPPING #-} Load DW Ix3 e where --- loadS = loadWindowedSRec --- {-# INLINE loadS #-} --- loadP = loadWindowedPRec --- {-# INLINE loadP #-} instance {-# OVERLAPPABLE #-} (Index ix, Load DW (Lower ix) e) => Load DW ix e where - loadS = loadWindowedSRec + loadS = loadWithIxN id {-# INLINE loadS #-} - loadP = loadWindowedPRec + loadP wIds arr unsafeRead unsafeWrite = + withScheduler_ wIds $ \scheduler -> + loadWithIxN (scheduleWork scheduler) arr unsafeRead unsafeWrite {-# INLINE loadP #-} + loadArray numWorkers' scheduleWork' arr = + loadArrayWithStride numWorkers' scheduleWork' oneStride (size arr) arr + {-# INLINE loadArray #-} + loadArrayWithStride = loadArrayWithIxN + {-# INLINE loadArrayWithStride #-} +loadArrayWithIxN :: + (Index ix, Monad m, Load DW (Lower ix) e) + => Int + -> (m () -> m ()) + -> Stride ix + -> ix + -> Array DW ix e + -> (Int -> m e) + -> (Int -> e -> m ()) + -> m () +loadArrayWithIxN numWorkers' scheduleWork' stride szResult arr unsafeRead unsafeWrite = do + let DWArray darr mStencilSize window = arr + DArray {dSize = szSource, dIndex = indexBorder} = darr + Window {windowStart, windowSize, windowIndex = indexWindow} = fromMaybe zeroWindow window + !(headSourceSize, lowerSourceSize) = unconsDim szSource + !lowerSize = tailDim szResult + !(s, lowerStrideIx) = unconsDim $ unStride stride + !(curWindowStart, lowerWindowStart) = unconsDim windowStart + !curWindowEnd = curWindowStart + headDim windowSize + !pageElements = totalElem lowerSize + -- can safely drop the dim, only last 2 matter anyways + !mLowerStencilSize = fmap tailDim mStencilSize + loadLower !i = + let !lowerWindow = + Window + { windowStart = lowerWindowStart + , windowSize = tailDim windowSize + , windowIndex = indexWindow . consDim i + } + !lowerArr = + DWArray + { dwArray = DArray Seq lowerSourceSize (indexBorder . consDim i) + , dwStencilSize = mLowerStencilSize + , dwWindow = Just lowerWindow + } + in loadArrayWithStride + numWorkers' + scheduleWork' + (Stride lowerStrideIx) + lowerSize + lowerArr + (\k -> unsafeRead (k + pageElements * (i `div` s))) + (\k -> unsafeWrite (k + pageElements * (i `div` s))) + {-# NOINLINE loadLower #-} + loopM_ 0 (< headDim windowStart) (+ s) loadLower + loopM_ (strideStart (Stride s) curWindowStart) (< curWindowEnd) (+ s) loadLower + loopM_ (strideStart (Stride s) curWindowEnd) (< headSourceSize) (+ s) loadLower +{-# INLINE loadArrayWithIxN #-} -loadWindowedSRec :: (Index ix, Load DW (Lower ix) e, Monad m) => - Array DW ix e -> (Int -> m e) -> (Int -> e -> m ()) -> m () -loadWindowedSRec (DWArray darr mStencilSz tix wSz indexW) _unsafeRead unsafeWrite = do - let DArray _ sz indexB = darr - !szL = tailDim sz - !bix = liftIndex2 (+) tix wSz - !(t, tixL) = unconsDim tix - !pageElements = totalElem szL - unsafeWriteLower i k val = unsafeWrite (k + pageElements * i) val - {-# INLINE unsafeWriteLower #-} - iterM_ zeroIndex tix (pureIndex 1) (<) $ \ !ix -> - unsafeWrite (toLinearIndex sz ix) (indexB ix) - iterM_ bix sz (pureIndex 1) (<) $ \ !ix -> - unsafeWrite (toLinearIndex sz ix) (indexB ix) - loopM_ t (< headDim bix) (+ 1) $ \ !i -> - let !lowerArr = - (DWArray - (DArray Seq szL (indexB . consDim i)) - (tailDim <$> mStencilSz) -- can safely drop the dim, only - -- last 2 matter anyways - tixL - (tailDim wSz) - (indexW . consDim i)) - in loadS lowerArr _unsafeRead (unsafeWriteLower i) -{-# INLINE loadWindowedSRec #-} -loadWindowedPRec :: (Index ix, Load DW (Lower ix) e) => - [Int] -> Array DW ix e -> (Int -> IO e) -> (Int -> e -> IO ()) -> IO () -loadWindowedPRec wIds (DWArray darr mStencilSz tix wSz indexW) _unsafeRead unsafeWrite = do - withScheduler_ wIds $ \ scheduler -> do - let DArray _ sz indexB = darr - !szL = tailDim sz - !bix = liftIndex2 (+) tix wSz - !(t, tixL) = unconsDim tix - !pageElements = totalElem szL - unsafeWriteLower i k = unsafeWrite (k + pageElements * i) - {-# INLINE unsafeWriteLower #-} - scheduleWork scheduler $ - iterM_ zeroIndex tix (pureIndex 1) (<) $ \ !ix -> - unsafeWrite (toLinearIndex sz ix) (indexB ix) - scheduleWork scheduler $ - iterM_ bix sz (pureIndex 1) (<) $ \ !ix -> - unsafeWrite (toLinearIndex sz ix) (indexB ix) - loopM_ t (< headDim bix) (+ 1) $ \ !i -> - let !lowerArr = - (DWArray - (DArray Seq szL (indexB . consDim i)) - (tailDim <$> mStencilSz) -- can safely drop the dim, only - -- last 2 matter anyways - tixL - (tailDim wSz) - (indexW . consDim i)) - in scheduleWork scheduler $ - loadS - lowerArr - (_unsafeRead) - (unsafeWriteLower i) -{-# INLINE loadWindowedPRec #-} +loadWithIxN :: + (Index ix, Monad m, Load DW (Lower ix) e) + => (m () -> m ()) + -> Array DW ix e + -> (Int -> m e) + -> (Int -> e -> m ()) + -> m () +loadWithIxN with arr unsafeRead unsafeWrite = do + let DWArray darr mStencilSize window = arr + DArray {dSize = sz, dIndex = indexBorder} = darr + Window {windowStart, windowSize, windowIndex = indexWindow} = fromMaybe zeroWindow window + !szL = tailDim sz + !windowEnd = liftIndex2 (+) windowStart windowSize + !(t, windowStartL) = unconsDim windowStart + !pageElements = totalElem szL + -- can safely drop the dim, only last 2 matter anyways + !stencilSizeLower = fmap tailDim mStencilSize + loadLower !i = + let !lowerWindow = + Window + { windowStart = windowStartL + , windowSize = tailDim windowSize + , windowIndex = indexWindow . consDim i + } + !lowerArr = + DWArray + { dwArray = DArray Seq szL (indexBorder . consDim i) + , dwStencilSize = stencilSizeLower + , dwWindow = Just lowerWindow + } + in with $ + loadS + lowerArr + (\k -> unsafeRead (k + pageElements * i)) + (\k -> unsafeWrite (k + pageElements * i)) + {-# NOINLINE loadLower #-} + loopM_ 0 (< headDim windowStart) (+ 1) loadLower + loopM_ t (< headDim windowEnd) (+ 1) loadLower + loopM_ (headDim windowEnd) (< headDim sz) (+ 1) loadLower +{-# INLINE loadWithIxN #-} unrollAndJam :: Monad m => - Int -> Ix2 -> Ix2 -> (Ix2 -> m a) -> m () -unrollAndJam !bH (it :. ib) (jt :. jb) f = do - let !bH' = min (max 1 bH) 7 + Int -- ^ Block height + -> Ix2 -- ^ Top corner + -> Ix2 -- ^ Bottom corner + -> Int -- ^ Column Stride + -> (Ix2 -> m ()) -- ^ Writing function + -> m () +unrollAndJam !bH (it :. jt) (ib :. jb) js f = do let f2 (i :. j) = f (i :. j) >> f ((i + 1) :. j) let f3 (i :. j) = f (i :. j) >> f2 ((i + 1) :. j) let f4 (i :. j) = f (i :. j) >> f3 ((i + 1) :. j) let f5 (i :. j) = f (i :. j) >> f4 ((i + 1) :. j) let f6 (i :. j) = f (i :. j) >> f5 ((i + 1) :. j) let f7 (i :. j) = f (i :. j) >> f6 ((i + 1) :. j) - let f' = case bH' of + let f' = case bH of 1 -> f 2 -> f2 3 -> f3 @@ -327,95 +442,51 @@ 5 -> f5 6 -> f6 _ -> f7 - let !ibS = ib - ((ib - it) `mod` bH') - loopM_ it (< ibS) (+ bH') $ \ !i -> - loopM_ jt (< jb) (+ 1) $ \ !j -> + let !ibS = ib - ((ib - it) `mod` bH) + loopM_ it (< ibS) (+ bH) $ \ !i -> + loopM_ jt (< jb) (+ js) $ \ !j -> f' (i :. j) loopM_ ibS (< ib) (+ 1) $ \ !i -> - loopM_ jt (< jb) (+ 1) $ \ !j -> + loopM_ jt (< jb) (+ js) $ \ !j -> f (i :. j) {-# INLINE unrollAndJam #-} + -- TODO: Implement Hilbert curve +toIx2Window :: Window Ix2T e -> Window Ix2 e +toIx2Window Window {..} = + Window + { windowStart = toIx2 windowStart + , windowSize = toIx2 windowSize + , windowIndex = windowIndex . fromIx2 + } +{-# INLINE toIx2Window #-} +toIx2ArrayDW :: Array DW Ix2T e -> Array DW Ix2 e +toIx2ArrayDW DWArray {dwArray, dwStencilSize, dwWindow} = + DWArray + { dwArray = dwArray {dIndex = dIndex dwArray . fromIx2, dSize = toIx2 (dSize dwArray)} + , dwStencilSize = fmap toIx2 dwStencilSize + , dwWindow = fmap toIx2Window dwWindow + } +{-# INLINE toIx2ArrayDW #-} + + instance {-# OVERLAPPING #-} Load DW Ix2T e where - loadS arr _ unsafeWrite = do - let (DWArray (DArray _ sz@(m, n) indexB) mStencilSz (it, jt) (wm, wn) indexW) = - arr - let (ib, jb) = (wm + it, wn + jt) - blockHeight = case mStencilSz of - Just (i, _) -> i - _ -> 1 - iterM_ (0, 0) (it, n) (pureIndex 1) (<) $ \ !ix -> - unsafeWrite (toLinearIndex sz ix) (indexB ix) - iterM_ (ib, 0) (m, n) (pureIndex 1) (<) $ \ !ix -> - unsafeWrite (toLinearIndex sz ix) (indexB ix) - iterM_ (it, 0) (ib, jt) (pureIndex 1) (<) $ \ !ix -> - unsafeWrite (toLinearIndex sz ix) (indexB ix) - iterM_ (it, jb) (ib, n) (pureIndex 1) (<) $ \ !ix -> - unsafeWrite (toLinearIndex sz ix) (indexB ix) - unrollAndJamT blockHeight (it, ib) (jt, jb) $ \ !ix -> - unsafeWrite (toLinearIndex sz ix) (indexW ix) + loadS arr = loadS (toIx2ArrayDW arr) {-# INLINE loadS #-} - loadP wIds arr _ unsafeWrite = do - let (DWArray (DArray _ sz@(m, n) indexB) mStencilSz (it, jt) (wm, wn) indexW) = arr - withScheduler_ wIds $ \ scheduler -> do - let (ib, jb) = (wm + it, wn + jt) - blockHeight = case mStencilSz of - Just (i, _) -> i - _ -> 1 - !(chunkHeight, slackHeight) = wm `quotRem` numWorkers scheduler - let loadBlock !it' !ib' = - unrollAndJamT blockHeight (it', ib') (jt, jb) $ \ !ix -> - unsafeWrite (toLinearIndex sz ix) (indexW ix) - {-# INLINE loadBlock #-} - scheduleWork scheduler $ - iterM_ (0, 0) (it, n) (pureIndex 1) (<) $ \ !ix -> - unsafeWrite (toLinearIndex sz ix) (indexB ix) - scheduleWork scheduler $ - iterM_ (ib, 0) (m, n) (pureIndex 1) (<) $ \ !ix -> - unsafeWrite (toLinearIndex sz ix) (indexB ix) - scheduleWork scheduler $ - iterM_ (it, 0) (ib, jt) (pureIndex 1) (<) $ \ !ix -> - unsafeWrite (toLinearIndex sz ix) (indexB ix) - scheduleWork scheduler $ - iterM_ (it, jb) (ib, n) (pureIndex 1) (<) $ \ !ix -> - unsafeWrite (toLinearIndex sz ix) (indexB ix) - loopM_ 0 (< numWorkers scheduler) (+ 1) $ \ !wid -> do - let !it' = wid * chunkHeight + it - scheduleWork scheduler $ loadBlock it' (it' + chunkHeight) - when (slackHeight > 0) $ do - let !itSlack = (numWorkers scheduler) * chunkHeight + it - scheduleWork scheduler $ loadBlock itSlack (itSlack + slackHeight) + loadP wIds arr = loadP wIds (toIx2ArrayDW arr) {-# INLINE loadP #-} - - - -unrollAndJamT :: Monad m => - Int -> Ix2T -> Ix2T -> (Ix2T -> m a) -> m () -unrollAndJamT !bH (it, ib) (jt, jb) f = do - let !bH' = min (max 1 bH) 7 - let f2 !(i, j) = f (i, j) >> f (i+1, j) - let f3 !(i, j) = f (i, j) >> f2 (i+1, j) - let f4 !(i, j) = f (i, j) >> f3 (i+1, j) - let f5 !(i, j) = f (i, j) >> f4 (i+1, j) - let f6 !(i, j) = f (i, j) >> f5 (i+1, j) - let f7 !(i, j) = f (i, j) >> f6 (i+1, j) - let f' = case bH' of - 1 -> f - 2 -> f2 - 3 -> f3 - 4 -> f4 - 5 -> f5 - 6 -> f6 - _ -> f7 - let !ibS = ib - ((ib - it) `mod` bH') - loopM_ it (< ibS) (+ bH') $ \ !i -> - loopM_ jt (< jb) (+ 1) $ \ !j -> - f' (i, j) - loopM_ ibS (< ib) (+ 1) $ \ !i -> - loopM_ jt (< jb) (+ 1) $ \ !j -> - f (i, j) -{-# INLINE unrollAndJamT #-} + loadArray numWorkers' scheduleWork' arr = + loadArrayWithStride numWorkers' scheduleWork' oneStride (size arr) arr + {-# INLINE loadArray #-} + loadArrayWithStride numWorkers' scheduleWork' stride sz arr = + loadArrayWithStride + numWorkers' + scheduleWork' + (Stride $ toIx2 $ unStride stride) + (toIx2 sz) + (toIx2ArrayDW arr) + {-# INLINE loadArrayWithStride #-} diff --git a/src/Data/Massiv/Array/Manifest.hs b/src/Data/Massiv/Array/Manifest.hs --- a/src/Data/Massiv/Array/Manifest.hs +++ b/src/Data/Massiv/Array/Manifest.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -21,22 +22,93 @@ -- * Boxed , B(..) , N(..) + , Uninitialized(..) + -- ** Conversion + -- $boxed_conversion_note + , unwrapArray + , evalArray + , unwrapMutableArray + , evalMutableArray + , unwrapNormalFormArray + , evalNormalFormArray + , unwrapNormalFormMutableArray + , evalNormalFormMutableArray -- * Primitive , P(..) , Prim + -- ** Conversion + , toByteArray + , fromByteArray + , toMutableByteArray + , fromMutableByteArray -- * Storable , S(..) , Storable + -- ** Conversion + , toStorableVector + , toStorableMVector + -- ** Direct Pointer Access , withPtr , unsafeWithPtr -- * Unboxed , U(..) , Unbox + -- ** Conversion + , toUnboxedVector + , toUnboxedMVector + -- * ByteString Conversion + , fromByteString + , toByteString + , toBuilder ) where -import Data.Massiv.Array.Manifest.BoxedStrict -import Data.Massiv.Array.Manifest.BoxedNF +import Data.ByteString as S +import Data.ByteString.Builder +import Data.ByteString.Unsafe as SU +import Data.Massiv.Array.Manifest.Boxed import Data.Massiv.Array.Manifest.Internal import Data.Massiv.Array.Manifest.Primitive import Data.Massiv.Array.Manifest.Storable import Data.Massiv.Array.Manifest.Unboxed +import Data.Massiv.Array.Ops.Fold +import Data.Massiv.Core.Common +import Data.Word (Word8) + + + +-- | /O(1)/ - Convert a strict ByteString into a manifest array. Will return `Nothing` if length +-- doesn't match the total number of elements of new array. +-- +-- @since 0.2.1 +fromByteString :: + Comp -- ^ Computation strategy + -> ByteString -- ^ Strict ByteString to use as a source. + -> Array M Ix1 Word8 +fromByteString comp bs = MArray comp (S.length bs) (SU.unsafeIndex bs) +{-# INLINE fromByteString #-} + +-- | /O(n)/ - For now only sequentially convert an array into a strict ByteString +-- +-- @since 0.2.1 +toByteString :: + Source r ix Word8 + => Array r ix Word8 -- ^ Source array + -> ByteString +toByteString arr = + fst $ unfoldrN (totalElem (size arr)) (\ !i -> Just (unsafeLinearIndex arr i, i + 1)) 0 +{-# INLINE toByteString #-} + +-- | /O(n)/ - Conversion of array monoidally into a string Builder. +-- +-- @since 0.2.1 +toBuilder :: Source r ix e => (e -> Builder) -> Array r ix e -> Builder +toBuilder f = foldMono f +{-# INLINE toBuilder #-} + + +-- $boxed_conversion_note +-- +-- Important part of all conversions in this section is that the actual boxed +-- `Data.Primitive.Array.Array`, which holds the pointers to values isn't copied around, it is always +-- kept as the same array. Conversion to Massiv boxed array will undergo evaluation during which +-- computation strategies will be respected. diff --git a/src/Data/Massiv/Array/Manifest/Boxed.hs b/src/Data/Massiv/Array/Manifest/Boxed.hs new file mode 100644 --- /dev/null +++ b/src/Data/Massiv/Array/Manifest/Boxed.hs @@ -0,0 +1,515 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +-- | +-- Module : Data.Massiv.Array.Manifest.Boxed +-- Copyright : (c) Alexey Kuleshevich 2018 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- +module Data.Massiv.Array.Manifest.Boxed + ( B(..) + , N(..) + , Array(..) + , Uninitialized(..) + , unwrapArray + , evalArray + , unwrapMutableArray + , evalMutableArray + , unwrapNormalFormArray + , evalNormalFormArray + , unwrapNormalFormMutableArray + , evalNormalFormMutableArray + , castArrayToVector + , vectorToArray + , castVectorToArray + , seqArray + , deepseqArray + ) where + +import Control.DeepSeq (NFData (..), deepseq) +import Control.Exception +import Control.Monad.Primitive +import Control.Monad.ST (runST) +import qualified Data.Foldable as F (Foldable (..)) +import Data.Massiv.Array.Delayed.Internal (eq, ord) +import Data.Massiv.Array.Manifest.Internal (M, toManifest) +import Data.Massiv.Array.Manifest.List as L +import Data.Massiv.Array.Mutable +import Data.Massiv.Array.Ops.Fold.Internal +import Data.Massiv.Array.Unsafe (unsafeGenerateArray, + unsafeGenerateArrayP) +import Data.Massiv.Core.Common +import Data.Massiv.Core.List +import qualified Data.Primitive.Array as A +import qualified Data.Vector as VB +import qualified Data.Vector.Mutable as VB +import GHC.Base (build) +import GHC.Exts as GHC (IsList (..)) +import GHC.Prim +import GHC.Types +import Prelude hiding (mapM) + +#include "massiv.h" + +sizeofArray :: A.Array e -> Int +sizeofMutableArray :: A.MutableArray s e -> Int +#if MIN_VERSION_primitive(0,6,2) +sizeofArray = A.sizeofArray +sizeofMutableArray = A.sizeofMutableArray +#else +sizeofArray (A.Array a#) = I# (sizeofArray# a#) +sizeofMutableArray (A.MutableArray ma#) = I# (sizeofMutableArray# ma#) +#endif + +------------------ +-- Boxed Strict -- +------------------ + +-- | Array representation for Boxed elements. This structure is element and +-- spine strict, but elements are strict to Weak Head Normal Form (WHNF) only. +data B = B deriving Show + +type instance EltRepr B ix = M + +data instance Array B ix e = BArray { bComp :: !Comp + , bSize :: !ix + , bData :: {-# UNPACK #-} !(A.Array e) + } + +instance (Index ix, NFData e) => NFData (Array B ix e) where + rnf = (`deepseqArray` ()) + +instance (Index ix, Eq e) => Eq (Array B ix e) where + (==) = eq (==) + {-# INLINE (==) #-} + +instance (Index ix, Ord e) => Ord (Array B ix e) where + compare = ord compare + {-# INLINE compare #-} + +instance Index ix => Construct B ix e where + getComp = bComp + {-# INLINE getComp #-} + + setComp c arr = arr { bComp = c } + {-# INLINE setComp #-} + + unsafeMakeArray Seq !sz f = unsafeGenerateArray sz f + unsafeMakeArray (ParOn wIds) !sz f = unsafeGenerateArrayP wIds sz f + {-# INLINE unsafeMakeArray #-} + +instance Index ix => Source B ix e where + unsafeLinearIndex (BArray _ _ a) = + INDEX_CHECK("(Source B ix e).unsafeLinearIndex", sizeofArray, A.indexArray) a + {-# INLINE unsafeLinearIndex #-} + + +instance Index ix => Size B ix e where + size = bSize + {-# INLINE size #-} + + unsafeResize !sz !arr = arr { bSize = sz } + {-# INLINE unsafeResize #-} + + unsafeExtract !sIx !newSz !arr = unsafeExtract sIx newSz (toManifest arr) + {-# INLINE unsafeExtract #-} + + +instance ( NFData e + , Index ix + , Index (Lower ix) + , Elt M ix e ~ Array M (Lower ix) e + , Elt B ix e ~ Array M (Lower ix) e + ) => + OuterSlice B ix e where + unsafeOuterSlice arr = unsafeOuterSlice (toManifest arr) + {-# INLINE unsafeOuterSlice #-} + +instance ( NFData e + , Index ix + , Index (Lower ix) + , Elt M ix e ~ Array M (Lower ix) e + , Elt B ix e ~ Array M (Lower ix) e + ) => + InnerSlice B ix e where + unsafeInnerSlice arr = unsafeInnerSlice (toManifest arr) + {-# INLINE unsafeInnerSlice #-} + + +instance Index ix => Manifest B ix e where + + unsafeLinearIndexM (BArray _ _ a) = + INDEX_CHECK("(Manifest B ix e).unsafeLinearIndexM", sizeofArray, A.indexArray) a + {-# INLINE unsafeLinearIndexM #-} + + +instance Index ix => Mutable B ix e where + data MArray s B ix e = MBArray !ix {-# UNPACK #-} !(A.MutableArray s e) + + msize (MBArray sz _) = sz + {-# INLINE msize #-} + + unsafeThaw (BArray _ sz a) = MBArray sz <$> A.unsafeThawArray a + {-# INLINE unsafeThaw #-} + + unsafeFreeze comp (MBArray sz ma) = BArray comp sz <$> A.unsafeFreezeArray ma + {-# INLINE unsafeFreeze #-} + + unsafeNew sz = MBArray sz <$> A.newArray (totalElem sz) uninitialized + {-# INLINE unsafeNew #-} + + unsafeNewZero = unsafeNew + {-# INLINE unsafeNewZero #-} + + unsafeLinearRead (MBArray _ ma) = + INDEX_CHECK("(Mutable B ix e).unsafeLinearRead", sizeofMutableArray, A.readArray) ma + {-# INLINE unsafeLinearRead #-} + + unsafeLinearWrite (MBArray _ ma) i e = e `seq` + INDEX_CHECK("(Mutable B ix e).unsafeLinearWrite", sizeofMutableArray, A.writeArray) ma i e + {-# INLINE unsafeLinearWrite #-} + + +-- | Row-major sequential folding over a Boxed array. +instance Index ix => Foldable (Array B ix) where + foldl = lazyFoldlS + {-# INLINE foldl #-} + foldl' = foldlS + {-# INLINE foldl' #-} + foldr = foldrFB + {-# INLINE foldr #-} + foldr' = foldrS + {-# INLINE foldr' #-} + null (BArray _ sz _) = totalElem sz == 0 + {-# INLINE null #-} + sum = F.foldl' (+) 0 + {-# INLINE sum #-} + product = F.foldl' (*) 1 + {-# INLINE product #-} + length = totalElem . size + {-# INLINE length #-} + toList arr = build (\ c n -> foldrFB c n arr) + {-# INLINE toList #-} + + +instance ( IsList (Array L ix e) + , Nested LN ix e + , Nested L ix e + , Ragged L ix e + ) => + IsList (Array B ix e) where + type Item (Array B ix e) = Item (Array L ix e) + fromList = L.fromLists' Seq + {-# INLINE fromList #-} + toList = GHC.toList . toListArray + {-# INLINE toList #-} + +----------------------- +-- Boxed Normal Form -- +----------------------- + +-- | Array representation for Boxed elements. This structure is element and +-- spine strict, and elements are always in Normal Form (NF), therefore `NFData` +-- instance is required. +data N = N deriving Show + +type instance EltRepr N ix = M + +newtype instance Array N ix e = NArray { bArray :: Array B ix e } + +instance (Index ix, NFData e) => NFData (Array N ix e) where + rnf (NArray barr) = barr `deepseqArray` () + + +instance (Index ix, NFData e, Eq e) => Eq (Array N ix e) where + (==) = eq (==) + {-# INLINE (==) #-} + +instance (Index ix, NFData e, Ord e) => Ord (Array N ix e) where + compare = ord compare + {-# INLINE compare #-} + + +instance (Index ix, NFData e) => Construct N ix e where + getComp = bComp . bArray + {-# INLINE getComp #-} + + setComp c (NArray arr) = NArray (arr { bComp = c }) + {-# INLINE setComp #-} + + unsafeMakeArray Seq !sz f = NArray $ unsafeGenerateArray sz f + unsafeMakeArray (ParOn wIds) !sz f = NArray $ unsafeGenerateArrayP wIds sz f + {-# INLINE unsafeMakeArray #-} + +instance (Index ix, NFData e) => Source N ix e where + unsafeLinearIndex (NArray arr) = + INDEX_CHECK("(Source N ix e).unsafeLinearIndex", totalElem . size, unsafeLinearIndex) arr + {-# INLINE unsafeLinearIndex #-} + + +instance (Index ix, NFData e) => Size N ix e where + size = bSize . bArray + {-# INLINE size #-} + + unsafeResize !sz = NArray . unsafeResize sz . bArray + {-# INLINE unsafeResize #-} + + unsafeExtract !sIx !newSz !arr = unsafeExtract sIx newSz (toManifest arr) + {-# INLINE unsafeExtract #-} + + +instance ( NFData e + , Index ix + , Index (Lower ix) + , Elt M ix e ~ Array M (Lower ix) e + , Elt N ix e ~ Array M (Lower ix) e + ) => + OuterSlice N ix e where + unsafeOuterSlice = unsafeOuterSlice . toManifest + {-# INLINE unsafeOuterSlice #-} + +instance ( NFData e + , Index ix + , Index (Lower ix) + , Elt M ix e ~ Array M (Lower ix) e + , Elt N ix e ~ Array M (Lower ix) e + ) => + InnerSlice N ix e where + unsafeInnerSlice = unsafeInnerSlice . toManifest + {-# INLINE unsafeInnerSlice #-} + + +instance (Index ix, NFData e) => Manifest N ix e where + + unsafeLinearIndexM (NArray arr) = + INDEX_CHECK("(Manifest N ix e).unsafeLinearIndexM", totalElem . size, unsafeLinearIndexM) arr + {-# INLINE unsafeLinearIndexM #-} + + +instance (Index ix, NFData e) => Mutable N ix e where + newtype MArray s N ix e = MNArray { bmArray :: MArray s B ix e } + + msize = msize . bmArray + {-# INLINE msize #-} + + unsafeThaw (NArray arr) = MNArray <$> unsafeThaw arr + {-# INLINE unsafeThaw #-} + + unsafeFreeze comp (MNArray marr) = NArray <$> unsafeFreeze comp marr + {-# INLINE unsafeFreeze #-} + + unsafeNew sz = MNArray <$> unsafeNew sz + {-# INLINE unsafeNew #-} + + unsafeNewZero = unsafeNew + {-# INLINE unsafeNewZero #-} + + unsafeLinearRead (MNArray ma) = + INDEX_CHECK("(Mutable N ix e).unsafeLinearRead", totalElem . msize, unsafeLinearRead) ma + {-# INLINE unsafeLinearRead #-} + + unsafeLinearWrite (MNArray ma) i e = e `deepseq` + INDEX_CHECK("(Mutable N ix e).unsafeLinearWrite", totalElem . msize, unsafeLinearWrite) ma i e + {-# INLINE unsafeLinearWrite #-} + + +instance ( NFData e + , IsList (Array L ix e) + , Nested LN ix e + , Nested L ix e + , Ragged L ix e + ) => + IsList (Array N ix e) where + type Item (Array N ix e) = Item (Array L ix e) + fromList = L.fromLists' Seq + {-# INLINE fromList #-} + toList = GHC.toList . toListArray + {-# INLINE toList #-} + + +---------------------- +-- Helper functions -- +---------------------- + +-- | An error that gets thrown when an unitialized element of a boxed array gets accessed. Can only +-- happen when array was constructed with `unsafeNew`. +data Uninitialized = Uninitialized + +instance Show Uninitialized where + show Uninitialized = "Array element is uninitialized" + +instance Exception Uninitialized + + +uninitialized :: a +uninitialized = throw Uninitialized + + +-- -- | /O(1)/ - Unwrap a fully evaluated boxed array. +-- -- +-- -- @since 0.2.1 +-- unwrapNormalFormArray :: Array N ix e -> Array B ix e +-- unwrapNormalFormArray = bArray +-- {-# INLINE unwrapNormalFormArray #-} + +-- -- | /O(1)/ - Unwrap a fully evaluated mutable boxed array. +-- -- +-- -- @since 0.2.1 +-- unwrapNormalFormMutableArray :: MArray s N ix e -> MArray s B ix e +-- unwrapNormalFormMutableArray (MNArray marr) = marr +-- {-# INLINE unwrapNormalFormMutableArray #-} + +--------------------- +-- WHNF conversion -- +--------------------- + +-- | /O(1)/ - Unwrap boxed array. +-- +-- @since 0.2.1 +unwrapArray :: Array B ix e -> A.Array e +unwrapArray = bData +{-# INLINE unwrapArray #-} + +-- | /O(n)/ - Wrap a boxed array and evaluate all elements to a WHNF. +-- +-- @since 0.2.1 +evalArray :: + Comp -- ^ Computation strategy + -> A.Array e -- ^ Lazy boxed array from @primitive@ package. + -> Array B Ix1 e +evalArray = fromArraySeq (\a -> a `seqArray` a) +{-# INLINE evalArray #-} + +-- | /O(1)/ - Unwrap mutable boxed array. +-- +-- @since 0.2.1 +unwrapMutableArray :: MArray s B ix e -> A.MutableArray s e +unwrapMutableArray (MBArray _ marr) = marr +{-# INLINE unwrapMutableArray #-} + + +-- | /O(n)/ - Wrap mutable boxed array and evaluate all elements to WHNF. +-- +-- @since 0.2.1 +evalMutableArray :: + PrimMonad m + => A.MutableArray (PrimState m) e -- ^ Mutable array that will get wrapped + -> m (MArray (PrimState m) B Ix1 e) +evalMutableArray = fromMutableArraySeq seq +{-# INLINE evalMutableArray #-} + +------------------- +-- NF conversion -- +------------------- + +-- | /O(1)/ - Unwrap a fully evaluated boxed array. +-- +-- @since 0.2.1 +unwrapNormalFormArray :: Array N ix e -> A.Array e +unwrapNormalFormArray = bData . bArray +{-# INLINE unwrapNormalFormArray #-} + +-- | /O(n)/ - Wrap a boxed array and evaluate all elements to a Normal Form (NF). +-- +-- @since 0.2.1 +evalNormalFormArray :: + NFData e + => Comp -- ^ Computation strategy + -> A.Array e -- ^ Lazy boxed array + -> Array N Ix1 e +evalNormalFormArray = fromArraySeq (\a -> a `deepseqArray` NArray a) +{-# INLINE evalNormalFormArray #-} + + +-- | /O(1)/ - Unwrap a fully evaluated mutable boxed array. +-- +-- @since 0.2.1 +unwrapNormalFormMutableArray :: MArray s N ix e -> A.MutableArray s e +unwrapNormalFormMutableArray (MNArray (MBArray _ marr)) = marr +{-# INLINE unwrapNormalFormMutableArray #-} + + +-- | /O(n)/ - Wrap mutable boxed array and evaluate all elements to NF. +-- +-- @since 0.2.1 +evalNormalFormMutableArray :: + (PrimMonad m, NFData e) + => A.MutableArray (PrimState m) e + -> m (MArray (PrimState m) N Ix1 e) +evalNormalFormMutableArray marr = MNArray <$> fromMutableArraySeq deepseq marr +{-# INLINE evalNormalFormMutableArray #-} + + +---------------------- +-- Helper functions -- +---------------------- + +fromMutableArraySeq :: + PrimMonad m + => (e -> m () -> m a) + -> A.MutableArray (PrimState m) e + -> m (MArray (PrimState m) B Ix1 e) +fromMutableArraySeq with mbarr = do + let !sz = sizeofMutableArray mbarr + loopM_ 0 (< sz) (+ 1) $ \i -> A.readArray mbarr i >>= (`with` return ()) + return $! MBArray sz mbarr +{-# INLINE fromMutableArraySeq #-} + +fromArraySeq :: + (Array B Ix1 e -> a) + -> Comp + -> A.Array e + -> a +fromArraySeq with comp barr = with (BArray comp (sizeofArray barr) barr) +{-# INLINE fromArraySeq #-} + + +seqArray :: Index ix => Array B ix a -> t -> t +seqArray !arr t = foldlInternal (flip seq) () (flip seq) () arr `seq` t +{-# INLINE seqArray #-} + + +deepseqArray :: (NFData a, Index ix) => Array B ix a -> t -> t +deepseqArray !arr t = foldlInternal (flip deepseq) () (flip seq) () arr `seq` t +{-# INLINE deepseqArray #-} + + +-- | Helper function that converts a boxed `A.Array` into a `VB.Vector`. Supplied total number of +-- elements is assumed to be the same in the array as provided by the size. +castArrayToVector :: A.Array a -> VB.Vector a +castArrayToVector arr = runST $ do + marr <- A.unsafeThawArray arr + VB.unsafeFreeze $ VB.MVector 0 (sizeofArray arr) marr +{-# INLINE castArrayToVector #-} + +-- | Covert boxed `VB.Vector` into an `A.Array`. Sliced vectors will indure copying. +vectorToArray :: VB.Vector a -> A.Array a +vectorToArray v = + runST $ do + VB.MVector start len marr <- VB.unsafeThaw v + marr' <- + if start == 0 + then return marr + else A.cloneMutableArray marr start len + A.unsafeFreezeArray marr' +{-# INLINE vectorToArray #-} + + +-- | Cast a Boxed Vector into an Array, but only if it wasn't previously sliced. +castVectorToArray :: VB.Vector a -> Maybe (A.Array a) +castVectorToArray v = + runST $ do + VB.MVector start end marr <- VB.unsafeThaw v + if start == 0 && end == sizeofMutableArray marr + then Just <$> A.unsafeFreezeArray marr + else return Nothing +{-# INLINE castVectorToArray #-} diff --git a/src/Data/Massiv/Array/Manifest/BoxedNF.hs b/src/Data/Massiv/Array/Manifest/BoxedNF.hs deleted file mode 100644 --- a/src/Data/Massiv/Array/Manifest/BoxedNF.hs +++ /dev/null @@ -1,218 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} --- | --- Module : Data.Massiv.Array.Manifest.Boxed --- Copyright : (c) Alexey Kuleshevich 2018 --- License : BSD3 --- Maintainer : Alexey Kuleshevich --- Stability : experimental --- Portability : non-portable --- -module Data.Massiv.Array.Manifest.BoxedNF - ( N (..) - , Array(..) - , deepseqArray - , deepseqArrayP - , vectorFromArray - , vectorToArray - , castVectorToArray - ) where - -import Control.DeepSeq (NFData (..), deepseq) -import Control.Monad.ST (runST) -import Data.Massiv.Array.Delayed.Internal (eq, ord) -import Data.Massiv.Array.Manifest.Internal (M, toManifest) -import Data.Massiv.Array.Manifest.List as A -import Data.Massiv.Array.Mutable -import Data.Massiv.Array.Unsafe (unsafeGenerateArray, - unsafeGenerateArrayP) -import Data.Massiv.Core.Common -import Data.Massiv.Core.List -import Data.Massiv.Core.Scheduler -import qualified Data.Primitive.Array as A -import qualified Data.Vector as VB -import qualified Data.Vector.Mutable as VB -import GHC.Exts as GHC (IsList (..)) -import Prelude hiding (mapM) -import System.IO.Unsafe (unsafePerformIO) - --- | Array representation for Boxed elements. This structure is element and --- spine strict, and elements are always in Normal Form (NF), therefore `NFData` --- instance is required. -data N = N deriving Show - -type instance EltRepr N ix = M - -data instance Array N ix e = NArray { nComp :: Comp - , nSize :: !ix - , nData :: {-# UNPACK #-} !(A.Array e) - } - -instance (Index ix, NFData e) => NFData (Array N ix e) where - rnf (NArray comp sz arr) = -- comp `deepseq` sz `deepseq` a `seq` () - case comp of - Seq -> deepseqArray sz arr () - ParOn wIds -> deepseqArrayP wIds sz arr () - - -instance (Index ix, NFData e, Eq e) => Eq (Array N ix e) where - (==) = eq (==) - {-# INLINE (==) #-} - -instance (Index ix, NFData e, Ord e) => Ord (Array N ix e) where - compare = ord compare - {-# INLINE compare #-} - - -instance (Index ix, NFData e) => Construct N ix e where - getComp = nComp - {-# INLINE getComp #-} - - setComp c arr = arr { nComp = c } - {-# INLINE setComp #-} - - unsafeMakeArray Seq !sz f = unsafeGenerateArray sz f - unsafeMakeArray (ParOn wIds) !sz f = unsafeGenerateArrayP wIds sz f - {-# INLINE unsafeMakeArray #-} - -instance (Index ix, NFData e) => Source N ix e where - unsafeLinearIndex (NArray _ _ a) = A.indexArray a - {-# INLINE unsafeLinearIndex #-} - - -instance (Index ix, NFData e) => Size N ix e where - size = nSize - {-# INLINE size #-} - - unsafeResize !sz !arr = arr { nSize = sz } - {-# INLINE unsafeResize #-} - - unsafeExtract !sIx !newSz !arr = unsafeExtract sIx newSz (toManifest arr) - {-# INLINE unsafeExtract #-} - - -instance ( NFData e - , Index ix - , Index (Lower ix) - , Elt M ix e ~ Array M (Lower ix) e - , Elt N ix e ~ Array M (Lower ix) e - ) => - OuterSlice N ix e where - unsafeOuterSlice arr = unsafeOuterSlice (toManifest arr) - {-# INLINE unsafeOuterSlice #-} - -instance ( NFData e - , Index ix - , Index (Lower ix) - , Elt M ix e ~ Array M (Lower ix) e - , Elt N ix e ~ Array M (Lower ix) e - ) => - InnerSlice N ix e where - unsafeInnerSlice arr = unsafeInnerSlice (toManifest arr) - {-# INLINE unsafeInnerSlice #-} - - -instance (Index ix, NFData e) => Manifest N ix e where - - unsafeLinearIndexM (NArray _ _ a) = A.indexArray a - {-# INLINE unsafeLinearIndexM #-} - - -uninitialized :: a -uninitialized = error "Data.Array.Massiv.Manifest.BoxedNF: uninitialized element" - - -instance (Index ix, NFData e) => Mutable N ix e where - data MArray s N ix e = MNArray !ix {-# UNPACK #-} !(A.MutableArray s e) - - msize (MNArray sz _) = sz - {-# INLINE msize #-} - - unsafeThaw (NArray _ sz a) = MNArray sz <$> A.unsafeThawArray a - {-# INLINE unsafeThaw #-} - - unsafeFreeze comp (MNArray sz ma) = NArray comp sz <$> A.unsafeFreezeArray ma - {-# INLINE unsafeFreeze #-} - - unsafeNew sz = MNArray sz <$> A.newArray (totalElem sz) uninitialized - {-# INLINE unsafeNew #-} - - unsafeNewZero = unsafeNew - {-# INLINE unsafeNewZero #-} - - unsafeLinearRead (MNArray _ ma) i = A.readArray ma i - {-# INLINE unsafeLinearRead #-} - - unsafeLinearWrite (MNArray _ ma) i e = e `deepseq` A.writeArray ma i e - {-# INLINE unsafeLinearWrite #-} - - -deepseqArray :: (Index ix, NFData a) => ix -> A.Array a -> b -> b -deepseqArray sz arr b = - iter 0 (totalElem sz) 1 (<) b $ \ !i acc -> A.indexArray arr i `deepseq` acc -{-# INLINE deepseqArray #-} - - -deepseqArrayP :: (Index ix, NFData a) => [Int] -> ix -> A.Array a -> b -> b -deepseqArrayP wIds sz arr b = - unsafePerformIO $ do - divideWork_ wIds sz $ \ !scheduler !chunkLength !totalLength !slackStart -> do - loopM_ 0 (< slackStart) (+ chunkLength) $ \ !start -> - scheduleWork scheduler $ - loopM_ start (< (start + chunkLength)) (+ 1) $ \ !k -> - A.indexArray arr k `deepseq` return () - scheduleWork scheduler $ - loopM_ slackStart (< totalLength) (+ 1) $ \ !k -> - A.indexArray arr k `deepseq` return () - return b -{-# INLINE deepseqArrayP #-} - - -vectorFromArray :: Index ix => ix -> A.Array a -> VB.Vector a -vectorFromArray sz arr = runST $ do - marr <- A.unsafeThawArray arr - VB.unsafeFreeze $ VB.MVector 0 (totalElem sz) marr -{-# INLINE vectorFromArray #-} - - -vectorToArray :: VB.Vector a -> A.Array a -vectorToArray v = - runST $ do - VB.MVector start len marr <- VB.unsafeThaw v - marr' <- - if start == 0 - then return marr - else A.cloneMutableArray marr start len - A.unsafeFreezeArray marr' -{-# INLINE vectorToArray #-} - - --- | Cast a Boxed Vector into an Array, but only if it wasn't previously sliced. -castVectorToArray :: VB.Vector a -> Maybe (A.Array a) -castVectorToArray v = - runST $ do - VB.MVector start _ marr <- VB.unsafeThaw v - if start == 0 - then Just <$> A.unsafeFreezeArray marr - else return Nothing -{-# INLINE castVectorToArray #-} - - - -instance ( NFData e - , IsList (Array L ix e) - , Nested LN ix e - , Nested L ix e - , Ragged L ix e - ) => - IsList (Array N ix e) where - type Item (Array N ix e) = Item (Array L ix e) - fromList = A.fromLists' Seq - {-# INLINE fromList #-} - toList = GHC.toList . toListArray - {-# INLINE toList #-} diff --git a/src/Data/Massiv/Array/Manifest/BoxedStrict.hs b/src/Data/Massiv/Array/Manifest/BoxedStrict.hs deleted file mode 100644 --- a/src/Data/Massiv/Array/Manifest/BoxedStrict.hs +++ /dev/null @@ -1,180 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} --- | --- Module : Data.Massiv.Array.Manifest.Boxed --- Copyright : (c) Alexey Kuleshevich 2018 --- License : BSD3 --- Maintainer : Alexey Kuleshevich --- Stability : experimental --- Portability : non-portable --- -module Data.Massiv.Array.Manifest.BoxedStrict - ( B (..) - , Array(..) - ) where - -import Control.DeepSeq (NFData (..)) -import qualified Data.Foldable as F (Foldable (..)) -import Data.Massiv.Array.Delayed.Internal (eq, ord) -import Data.Massiv.Array.Manifest.BoxedNF (deepseqArray, - deepseqArrayP) -import Data.Massiv.Array.Unsafe (unsafeGenerateArray, - unsafeGenerateArrayP) -import Data.Massiv.Array.Manifest.Internal -import Data.Massiv.Array.Manifest.List as A -import Data.Massiv.Array.Mutable -import Data.Massiv.Array.Ops.Fold.Internal -import Data.Massiv.Core.Common -import Data.Massiv.Core.List -import qualified Data.Primitive.Array as A -import GHC.Base (build) -import GHC.Exts as GHC (IsList (..)) -import Prelude hiding (mapM) - - --- | Array representation for Boxed elements. This structure is element and --- spine strict, but elements are strict to Weak Head Normal Form (WHNF) only. -data B = B deriving Show - -type instance EltRepr B ix = M - -data instance Array B ix e = BArray { bComp :: !Comp - , bSize :: !ix - , bData :: {-# UNPACK #-} !(A.Array e) - } - -instance (Index ix, NFData e) => NFData (Array B ix e) where - rnf (BArray comp sz arr) = - case comp of - Seq -> deepseqArray sz arr () - ParOn wIds -> deepseqArrayP wIds sz arr () - -instance (Index ix, Eq e) => Eq (Array B ix e) where - (==) = eq (==) - {-# INLINE (==) #-} - -instance (Index ix, Ord e) => Ord (Array B ix e) where - compare = ord compare - {-# INLINE compare #-} - -instance Index ix => Construct B ix e where - getComp = bComp - {-# INLINE getComp #-} - - setComp c arr = arr { bComp = c } - {-# INLINE setComp #-} - - unsafeMakeArray Seq !sz f = unsafeGenerateArray sz f - unsafeMakeArray (ParOn wIds) !sz f = unsafeGenerateArrayP wIds sz f - {-# INLINE unsafeMakeArray #-} - -instance Index ix => Source B ix e where - unsafeLinearIndex (BArray _ _ a) = A.indexArray a - {-# INLINE unsafeLinearIndex #-} - - -instance Index ix => Size B ix e where - size = bSize - {-# INLINE size #-} - - unsafeResize !sz !arr = arr { bSize = sz } - {-# INLINE unsafeResize #-} - - unsafeExtract !sIx !newSz !arr = unsafeExtract sIx newSz (toManifest arr) - {-# INLINE unsafeExtract #-} - - -instance ( NFData e - , Index ix - , Index (Lower ix) - , Elt M ix e ~ Array M (Lower ix) e - , Elt B ix e ~ Array M (Lower ix) e - ) => - OuterSlice B ix e where - unsafeOuterSlice arr = unsafeOuterSlice (toManifest arr) - {-# INLINE unsafeOuterSlice #-} - -instance ( NFData e - , Index ix - , Index (Lower ix) - , Elt M ix e ~ Array M (Lower ix) e - , Elt B ix e ~ Array M (Lower ix) e - ) => - InnerSlice B ix e where - unsafeInnerSlice arr = unsafeInnerSlice (toManifest arr) - {-# INLINE unsafeInnerSlice #-} - - -instance Index ix => Manifest B ix e where - - unsafeLinearIndexM (BArray _ _ a) = A.indexArray a - {-# INLINE unsafeLinearIndexM #-} - - -uninitialized :: a -uninitialized = error "Data.Array.Massiv.Manifest.BoxedStrict: uninitialized element" - - -instance Index ix => Mutable B ix e where - data MArray s B ix e = MBArray !ix {-# UNPACK #-} !(A.MutableArray s e) - - msize (MBArray sz _) = sz - {-# INLINE msize #-} - - unsafeThaw (BArray _ sz a) = MBArray sz <$> A.unsafeThawArray a - {-# INLINE unsafeThaw #-} - - unsafeFreeze comp (MBArray sz ma) = BArray comp sz <$> A.unsafeFreezeArray ma - {-# INLINE unsafeFreeze #-} - - unsafeNew sz = MBArray sz <$> A.newArray (totalElem sz) uninitialized - {-# INLINE unsafeNew #-} - - unsafeNewZero = unsafeNew - {-# INLINE unsafeNewZero #-} - - unsafeLinearRead (MBArray _ ma) i = A.readArray ma i - {-# INLINE unsafeLinearRead #-} - - unsafeLinearWrite (MBArray _ ma) i e = e `seq` A.writeArray ma i e - {-# INLINE unsafeLinearWrite #-} - - --- | Row-major sequential folding over a Boxed array. -instance Index ix => Foldable (Array B ix) where - foldl = lazyFoldlS - {-# INLINE foldl #-} - foldl' = foldlS - {-# INLINE foldl' #-} - foldr = foldrFB - {-# INLINE foldr #-} - foldr' = foldrS - {-# INLINE foldr' #-} - null (BArray _ sz _) = totalElem sz == 0 - {-# INLINE null #-} - sum = F.foldl' (+) 0 - {-# INLINE sum #-} - product = F.foldl' (*) 1 - {-# INLINE product #-} - length = totalElem . size - {-# INLINE length #-} - toList arr = build (\ c n -> foldrFB c n arr) - {-# INLINE toList #-} - - -instance ( IsList (Array L ix e) - , Nested LN ix e - , Nested L ix e - , Ragged L ix e - ) => - IsList (Array B ix e) where - type Item (Array B ix e) = Item (Array L ix e) - fromList = A.fromLists' Seq - {-# INLINE fromList #-} - toList = GHC.toList . toListArray - {-# INLINE toList #-} diff --git a/src/Data/Massiv/Array/Manifest/Internal.hs b/src/Data/Massiv/Array/Manifest/Internal.hs --- a/src/Data/Massiv/Array/Manifest/Internal.hs +++ b/src/Data/Massiv/Array/Manifest/Internal.hs @@ -1,6 +1,8 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MagicHash #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} @@ -25,6 +27,8 @@ , computeProxy , computeSource , computeInto + , computeWithStride + , computeWithStrideAs , clone , convert , convertAs @@ -36,6 +40,8 @@ , sequenceOnP , fromRaggedArray , fromRaggedArray' + , sizeofArray + , sizeofMutableArray ) where import Control.Exception (try) @@ -51,18 +57,46 @@ import Data.Maybe (fromMaybe) import Data.Typeable import qualified Data.Vector as V -import GHC.Base (build) +import GHC.Base hiding (ord) import System.IO.Unsafe (unsafePerformIO) +#if MIN_VERSION_primitive(0,6,2) +import Data.Primitive.Array (sizeofArray, + sizeofMutableArray) + +#else +import qualified Data.Primitive.Array as A (Array (..), + MutableArray (..)) +import GHC.Prim (sizeofArray#, + sizeofMutableArray#) + +sizeofArray :: A.Array a -> Int +sizeofArray (A.Array a) = I# (sizeofArray# a) +{-# INLINE sizeofArray #-} + +sizeofMutableArray :: A.MutableArray s a -> Int +sizeofMutableArray (A.MutableArray ma) = I# (sizeofMutableArray# ma) +{-# INLINE sizeofMutableArray #-} +#endif + + -- | General Manifest representation data M data instance Array M ix e = MArray { mComp :: !Comp , mSize :: !ix - , mUnsafeLinearIndex :: Int -> e } + , mLinearIndex :: Int -> e } type instance EltRepr M ix = M +instance (Eq e, Index ix) => Eq (Array M ix e) where + (==) = eq (==) + {-# INLINE (==) #-} + +instance (Ord e, Index ix) => Ord (Array M ix e) where + compare = ord compare + {-# INLINE compare #-} + instance Index ix => Construct M ix e where getComp = mComp {-# INLINE getComp #-} @@ -81,7 +115,7 @@ -- | /O(1)/ - Conversion of `Manifest` arrays to `M` representation. toManifest :: Manifest r ix e => Array r ix e -> Array M ix e -toManifest !arr = MArray (getComp arr) (size arr) (unsafeLinearIndexM arr) where +toManifest !arr = MArray (getComp arr) (size arr) (unsafeLinearIndexM arr) {-# INLINE toManifest #-} @@ -109,13 +143,13 @@ instance Index ix => Source M ix e where - unsafeLinearIndex = mUnsafeLinearIndex + unsafeLinearIndex = mLinearIndex {-# INLINE unsafeLinearIndex #-} instance Index ix => Manifest M ix e where - unsafeLinearIndexM = mUnsafeLinearIndex + unsafeLinearIndexM = mLinearIndex {-# INLINE unsafeLinearIndexM #-} @@ -163,7 +197,7 @@ {-# INLINE unsafeInnerSlice #-} instance (Elt M ix e ~ Array M (Lower ix) e, Index ix, Index (Lower ix)) => InnerSlice M ix e where - unsafeInnerSlice !arr !(szL, m) !i = + unsafeInnerSlice !arr (szL, m) !i = MArray (getComp arr) szL (\k -> unsafeLinearIndex arr (k * m + kStart)) where !kStart = toLinearIndex (size arr) (snocDim (zeroIndex :: Lower ix) i) @@ -175,7 +209,7 @@ iterM_ 0 (totalElem sz) 1 (<) $ \ !i -> uWrite i (f i) {-# INLINE loadS #-} - loadP wIds (MArray _ sz f) _ uWrite = do + loadP wIds (MArray _ sz f) _ uWrite = divideWork_ wIds (totalElem sz) $ \ !scheduler !chunkLength !totalLength !slackStart -> do loopM_ 0 (< slackStart) (+ chunkLength) $ \ !start -> scheduleWork scheduler $ @@ -185,6 +219,9 @@ iterM_ slackStart totalLength 1 (<) $ \ !i -> uWrite i (f i) {-# INLINE loadP #-} + loadArray numWorkers' scheduleWork' (MArray _ sz f) _ = + splitLinearlyWith_ numWorkers' scheduleWork' (totalElem sz) f + {-# INLINE loadArray #-} loadMutableS :: (Load r' ix e, Mutable r ix e) => @@ -204,6 +241,7 @@ unsafeFreeze (ParOn wIds) mArr {-# INLINE loadMutableOnP #-} + -- | Ensure that Array is computed, i.e. represented with concrete elements in memory, hence is the -- `Mutable` type class restriction. Use `setComp` if you'd like to change computation strategy -- before calling @compute@ @@ -267,7 +305,7 @@ computeSource :: forall r' r ix e . (Source r' ix e, Mutable r ix e) => Array r' ix e -> Array r ix e computeSource arr = - fromMaybe (compute $ delay arr) $ fmap (\Refl -> arr) (eqT :: Maybe (r' :~: r)) + maybe (compute $ delay arr) (\Refl -> arr) (eqT :: Maybe (r' :~: r)) {-# INLINE computeSource #-} @@ -334,12 +372,15 @@ let loadWith using = loadRagged using (unsafeLinearWrite mArr) 0 (totalElem sz) (tailDim sz) arr try $ case getComp arr of - Seq -> do + c -> do loadWith id - unsafeFreeze Seq mArr - pComp@(ParOn ss) -> do - withScheduler_ ss (loadWith . scheduleWork) - unsafeFreeze pComp mArr + unsafeFreeze c mArr + -- Seq -> do + -- loadWith id + -- unsafeFreeze Seq mArr + -- pComp@(ParOn ss) -> do + -- withScheduler_ ss (loadWith . scheduleWork) + -- unsafeFreeze pComp mArr {-# INLINE fromRaggedArray #-} -- | Same as `fromRaggedArray`, but will throw an error if its shape is not @@ -352,3 +393,48 @@ Left RowTooLongError -> error "Too many elements in a row" Right resArr -> resArr {-# INLINE fromRaggedArray' #-} + + + + +-- | Same as `compute`, but with `Stride`. +computeWithStride :: (Load r' ix e, Mutable r ix e) => Stride ix -> Array r' ix e -> Array r ix e +computeWithStride stride !arr = + unsafePerformIO $ do + let sz = strideSize stride (size arr) + comp = getComp arr + mArr <- unsafeNew sz + case comp of + Seq -> loadArrayWithStride 1 id stride sz arr (unsafeLinearRead mArr) (unsafeLinearWrite mArr) + ParOn wIds -> + withScheduler_ wIds $ \scheduler -> + loadArrayWithStride + (numWorkers scheduler) + (scheduleWork scheduler) + stride + sz + arr + (unsafeLinearRead mArr) + (unsafeLinearWrite mArr) + -- -- Alternative way to run computation sequentially: decreaseas compile time + -- let wIds = case comp of + -- Seq -> [1] + -- ParOn caps -> caps + -- withScheduler_ wIds $ \scheduler -> + -- loadArrayWithStride + -- (numWorkers scheduler) + -- (scheduleWork scheduler) + -- stride + -- sz + -- arr + -- (unsafeLinearRead mArr) + -- (unsafeLinearWrite mArr) + unsafeFreeze comp mArr +{-# INLINE computeWithStride #-} + + +-- | Same as `computeWithStride`, but with ability to specify resulting array representation. +computeWithStrideAs :: + (Load r' ix e, Mutable r ix e) => r -> Stride ix -> Array r' ix e -> Array r ix e +computeWithStrideAs _ = computeWithStride +{-# INLINE computeWithStrideAs #-} diff --git a/src/Data/Massiv/Array/Manifest/List.hs b/src/Data/Massiv/Array/Manifest/List.hs --- a/src/Data/Massiv/Array/Manifest/List.hs +++ b/src/Data/Massiv/Array/Manifest/List.hs @@ -152,7 +152,7 @@ -- , [ [ (1,0,0),(1,0,1),(1,0,2) ] -- ] -- ]) --- >>> toList arr +-- >>> toLists arr -- [[[(0,0,0),(0,0,1),(0,0,2)]],[[(1,0,0),(1,0,1),(1,0,2)]]] -- toLists :: (Nested LN ix e, Nested L ix e, Construct L ix e, Source r ix e) diff --git a/src/Data/Massiv/Array/Manifest/Primitive.hs b/src/Data/Massiv/Array/Manifest/Primitive.hs --- a/src/Data/Massiv/Array/Manifest/Primitive.hs +++ b/src/Data/Massiv/Array/Manifest/Primitive.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MagicHash #-} @@ -20,6 +21,10 @@ , Array(..) , Prim , vectorToByteArray + , toByteArray + , fromByteArray + , toMutableByteArray + , fromMutableByteArray ) where import Control.DeepSeq (NFData (..), deepseq) @@ -36,11 +41,13 @@ import Data.Primitive.ByteArray import Data.Primitive.Types import qualified Data.Vector.Primitive as VP -import GHC.Base (Int(..)) +import GHC.Base (Int (..)) import GHC.Exts as GHC (IsList (..)) import GHC.Prim import Prelude hiding (mapM) +#include "massiv.h" + -- | Representation for `Prim`itive elements data P = P deriving Show @@ -51,7 +58,7 @@ , pData :: {-# UNPACK #-} !ByteArray } -instance (Index ix, NFData e) => NFData (Array P ix e) where +instance Index ix => NFData (Array P ix e) where rnf (PArray c sz a) = c `deepseq` sz `deepseq` a `seq` () {-# INLINE rnf #-} @@ -74,8 +81,14 @@ unsafeMakeArray (ParOn wIds) !sz f = unsafeGenerateArrayP wIds sz f {-# INLINE unsafeMakeArray #-} +elemsByteArray :: Prim a => a -> ByteArray -> Int +elemsByteArray dummy a = sizeofByteArray a `div` sizeOf dummy +{-# INLINE elemsByteArray #-} + instance (Prim e, Index ix) => Source P ix e where - unsafeLinearIndex (PArray _ _ a) = indexByteArray a + unsafeLinearIndex (PArray _ _ a) = + INDEX_CHECK("(Source P ix e).unsafeLinearIndex", + elemsByteArray (undefined :: e), indexByteArray) a {-# INLINE unsafeLinearIndex #-} @@ -106,7 +119,7 @@ {-# INLINE unsafeSlice #-} instance {-# OVERLAPPING #-} Prim e => OuterSlice P Ix1 e where - unsafeOuterSlice = unsafeLinearIndex + unsafeOuterSlice = unsafeLinearIndex {-# INLINE unsafeOuterSlice #-} instance ( Prim e @@ -136,10 +149,16 @@ instance (Index ix, Prim e) => Manifest P ix e where - unsafeLinearIndexM (PArray _ _ a) = indexByteArray a + unsafeLinearIndexM (PArray _ _ a) = + INDEX_CHECK("(Manifest P ix e).unsafeLinearIndexM", + elemsByteArray (undefined :: e), indexByteArray) a {-# INLINE unsafeLinearIndexM #-} +elemsMutableByteArray :: Prim a => a -> MutableByteArray s -> Int +elemsMutableByteArray dummy a = sizeofMutableByteArray a `div` sizeOf dummy +{-# INLINE elemsMutableByteArray #-} + instance (Index ix, Prim e) => Mutable P ix e where data MArray s P ix e = MPArray !ix !(MutableByteArray s) @@ -152,20 +171,24 @@ unsafeFreeze comp (MPArray sz a) = PArray comp sz <$> unsafeFreezeByteArray a {-# INLINE unsafeFreeze #-} - unsafeNew sz = MPArray sz <$> newByteArray (totalElem sz * sizeOf (undefined :: e)) + unsafeNew sz = MPArray sz <$> newByteArray (I# (totalSize# sz (undefined :: e))) {-# INLINE unsafeNew #-} unsafeNewZero sz = do - let szBytes = totalElem sz * sizeOf (undefined :: e) + let !szBytes = I# (totalSize# sz (undefined :: e)) barr <- newByteArray szBytes fillByteArray barr 0 szBytes 0 return $ MPArray sz barr {-# INLINE unsafeNewZero #-} - unsafeLinearRead (MPArray _ a) = readByteArray a + unsafeLinearRead (MPArray _ ma) = + INDEX_CHECK("(Mutable P ix e).unsafeLinearRead", + elemsMutableByteArray (undefined :: e), readByteArray) ma {-# INLINE unsafeLinearRead #-} - unsafeLinearWrite (MPArray _ v) = writeByteArray v + unsafeLinearWrite (MPArray _ ma) = + INDEX_CHECK("(Mutable P ix e).unsafeLinearWrite", + elemsMutableByteArray (undefined :: e), writeByteArray) ma {-# INLINE unsafeLinearWrite #-} unsafeNewA sz (State s#) = @@ -221,3 +244,50 @@ unsafeFreezeByteArray marr {-# INLINE vectorToByteArray #-} + +primArrayDummy :: arr P ix e -> e +primArrayDummy = undefined +{-# INLINE primArrayDummy #-} + + +-- | /O(1)/ - Extract the internal `ByteArray`. +-- +-- @since 0.2.1 +toByteArray :: Array P ix e -> ByteArray +toByteArray = pData +{-# INLINE toByteArray #-} + + +-- | /O(1)/ - Construct a primitive array from the `ByteArray`. Will return `Nothing` if number of +-- elements doesn't match. +-- +-- @since 0.2.1 +fromByteArray :: (Index ix, Prim e) => Comp -> ix -> ByteArray -> Maybe (Array P ix e) +fromByteArray comp sz ba + | totalElem sz /= elemsByteArray (primArrayDummy arr) ba = Nothing + | otherwise = Just arr + where + arr = PArray comp sz ba +{-# INLINE fromByteArray #-} + + + +-- | /O(1)/ - Extract the internal `MutableByteArray`. +-- +-- @since 0.2.1 +toMutableByteArray :: MArray s P ix e -> MutableByteArray s +toMutableByteArray (MPArray _ mba) = mba +{-# INLINE toMutableByteArray #-} + + +-- | /O(1)/ - Construct a primitive mutable array from the `MutableByteArray`. Will return `Nothing` +-- if number of elements doesn't match. +-- +-- @since 0.2.1 +fromMutableByteArray :: (Index ix, Prim e) => ix -> MutableByteArray s -> Maybe (MArray s P ix e) +fromMutableByteArray sz ba + | totalElem sz /= elemsMutableByteArray (primArrayDummy marr) ba = Nothing + | otherwise = Just marr + where + marr = MPArray sz ba +{-# INLINE fromMutableByteArray #-} diff --git a/src/Data/Massiv/Array/Manifest/Storable.hs b/src/Data/Massiv/Array/Manifest/Storable.hs --- a/src/Data/Massiv/Array/Manifest/Storable.hs +++ b/src/Data/Massiv/Array/Manifest/Storable.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -17,6 +18,8 @@ ( S (..) , Array(..) , VS.Storable + , toStorableVector + , toStorableMVector , withPtr , unsafeWithPtr ) where @@ -36,6 +39,8 @@ import GHC.Exts as GHC (IsList (..)) import Prelude hiding (mapM) +#include "massiv.h" + -- | Representation for `Storable` elements data S = S deriving Show @@ -46,7 +51,7 @@ , sData :: !(VS.Vector e) } -instance (Index ix, NFData e) => NFData (Array S ix e) where +instance Index ix => NFData (Array S ix e) where rnf (SArray c sz v) = c `deepseq` sz `deepseq` v `deepseq` () instance (VS.Storable e, Eq e, Index ix) => Eq (Array S ix e) where @@ -70,7 +75,8 @@ instance (VS.Storable e, Index ix) => Source S ix e where - unsafeLinearIndex (SArray _ _ v) = VS.unsafeIndex v + unsafeLinearIndex (SArray _ _ v) = + INDEX_CHECK("(Source S ix e).unsafeLinearIndex", VS.length, VS.unsafeIndex) v {-# INLINE unsafeLinearIndex #-} @@ -109,7 +115,8 @@ instance (Index ix, VS.Storable e) => Manifest S ix e where - unsafeLinearIndexM (SArray _ _ v) = VS.unsafeIndex v + unsafeLinearIndexM (SArray _ _ v) = + INDEX_CHECK("(Manifest S ix e).unsafeLinearIndexM", VS.length, VS.unsafeIndex) v {-# INLINE unsafeLinearIndexM #-} @@ -131,10 +138,12 @@ unsafeNewZero sz = MSArray sz <$> MVS.new (totalElem sz) {-# INLINE unsafeNewZero #-} - unsafeLinearRead (MSArray _ v) i = MVS.unsafeRead v i + unsafeLinearRead (MSArray _ mv) = + INDEX_CHECK("(Mutable S ix e).unsafeLinearRead", MVS.length, MVS.unsafeRead) mv {-# INLINE unsafeLinearRead #-} - unsafeLinearWrite (MSArray _ v) i = MVS.unsafeWrite v i + unsafeLinearWrite (MSArray _ mv) = + INDEX_CHECK("(Mutable S ix e).unsafeLinearWrite", MVS.length, MVS.unsafeWrite) mv {-# INLINE unsafeLinearWrite #-} @@ -151,8 +160,8 @@ toList = GHC.toList . toListArray {-# INLINE toList #-} --- | A pointer to the beginning of originally created array, i.e. various index manipulation --- functions that do slicing, extracting, etc. have no affect on this pointer. +-- | A pointer to the beginning of the storable array. It is unsafe since it can break referential +-- transparency. -- -- @since 0.1.3 unsafeWithPtr :: VS.Storable a => Array S ix a -> (Ptr a -> IO b) -> IO b @@ -165,3 +174,19 @@ -- @since 0.1.3 withPtr :: (Index ix, VS.Storable a) => MArray RealWorld S ix a -> (Ptr a -> IO b) -> IO b withPtr (MSArray _ mv) = MVS.unsafeWith mv + + +-- | /O(1)/ - Unwrap storable array and pull out the underlying storable vector. +-- +-- @since 0.2.1 +toStorableVector :: Array S ix e -> VS.Vector e +toStorableVector = sData +{-# INLINE toStorableVector #-} + + +-- | /O(1)/ - Unwrap storable mutable array and pull out the underlying storable mutable vector. +-- +-- @since 0.2.1 +toStorableMVector :: MArray s S ix e -> VS.MVector s e +toStorableMVector (MSArray _ mv) = mv +{-# INLINE toStorableMVector #-} diff --git a/src/Data/Massiv/Array/Manifest/Unboxed.hs b/src/Data/Massiv/Array/Manifest/Unboxed.hs --- a/src/Data/Massiv/Array/Manifest/Unboxed.hs +++ b/src/Data/Massiv/Array/Manifest/Unboxed.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -17,6 +18,8 @@ ( U (..) , VU.Unbox , Array(..) + , toUnboxedVector + , toUnboxedMVector ) where import Control.DeepSeq (NFData (..), deepseq) @@ -33,6 +36,8 @@ import GHC.Exts as GHC (IsList (..)) import Prelude hiding (mapM) +#include "massiv.h" + -- | Representation for `Unbox`ed elements data U = U deriving Show @@ -70,7 +75,8 @@ instance (VU.Unbox e, Index ix) => Source U ix e where - unsafeLinearIndex (UArray _ _ v) = VU.unsafeIndex v + unsafeLinearIndex (UArray _ _ v) = + INDEX_CHECK("(Source U ix e).unsafeLinearIndex", VU.length, VU.unsafeIndex) v {-# INLINE unsafeLinearIndex #-} @@ -131,7 +137,8 @@ instance (VU.Unbox e, Index ix) => Manifest U ix e where - unsafeLinearIndexM (UArray _ _ v) = VU.unsafeIndex v + unsafeLinearIndexM (UArray _ _ v) = + INDEX_CHECK("(Manifest U ix e).unsafeLinearIndexM", VU.length, VU.unsafeIndex) v {-# INLINE unsafeLinearIndexM #-} instance (VU.Unbox e, Index ix) => Mutable U ix e where @@ -152,10 +159,12 @@ unsafeNewZero sz = MUArray sz <$> MVU.new (totalElem sz) {-# INLINE unsafeNewZero #-} - unsafeLinearRead (MUArray _ v) i = MVU.unsafeRead v i + unsafeLinearRead (MUArray _ mv) = + INDEX_CHECK("(Mutable U ix e).unsafeLinearRead", MVU.length, MVU.unsafeRead) mv {-# INLINE unsafeLinearRead #-} - unsafeLinearWrite (MUArray _ v) i = MVU.unsafeWrite v i + unsafeLinearWrite (MUArray _ mv) = + INDEX_CHECK("(Mutable U ix e).unsafeLinearWrite", MVU.length, MVU.unsafeWrite) mv {-# INLINE unsafeLinearWrite #-} @@ -171,3 +180,19 @@ {-# INLINE fromList #-} toList = GHC.toList . toListArray {-# INLINE toList #-} + + +-- | /O(1)/ - Unwrap unboxed array and pull out the underlying unboxed vector. +-- +-- @since 0.2.1 +toUnboxedVector :: Array U ix e -> VU.Vector e +toUnboxedVector = uData +{-# INLINE toUnboxedVector #-} + + +-- | /O(1)/ - Unwrap unboxed mutable array and pull out the underlying unboxed mutable vector. +-- +-- @since 0.2.1 +toUnboxedMVector :: MArray s U ix e -> VU.MVector s e +toUnboxedMVector (MUArray _ mv) = mv +{-# INLINE toUnboxedMVector #-} diff --git a/src/Data/Massiv/Array/Manifest/Vector.hs b/src/Data/Massiv/Array/Manifest/Vector.hs --- a/src/Data/Massiv/Array/Manifest/Vector.hs +++ b/src/Data/Massiv/Array/Manifest/Vector.hs @@ -22,8 +22,7 @@ ) where import Control.Monad (guard, join, msum) -import Data.Massiv.Array.Manifest.BoxedNF -import Data.Massiv.Array.Manifest.BoxedStrict +import Data.Massiv.Array.Manifest.Boxed import Data.Massiv.Array.Manifest.Internal import Data.Massiv.Array.Manifest.Primitive import Data.Massiv.Array.Manifest.Storable @@ -76,7 +75,8 @@ , do Refl <- eqT :: Maybe (v :~: VB.Vector) bVector <- join $ gcast1 (Just vector) arr <- castVectorToArray bVector - return $ BArray {bComp = comp, bSize = sz, bData = arr} + let barr = BArray {bComp = comp, bSize = sz, bData = arr} + barr `seqArray` return barr ] {-# NOINLINE castFromVector #-} @@ -99,7 +99,7 @@ then error $ "Data.Array.Massiv.Manifest.fromVector: Supplied size: " ++ show sz ++ " doesn't match vector length: " ++ show (VG.length v) - else unsafeMakeArray comp sz ((v VG.!) . toLinearIndex sz) + else makeArray comp sz ((VG.unsafeIndex v) . toLinearIndex sz) {-# NOINLINE fromVector #-} @@ -121,10 +121,10 @@ return $ VP.Vector 0 (totalElem (size arr)) $ pData pArr , do Refl <- eqT :: Maybe (r :~: B) bArr <- gcastArr arr - return $ vectorFromArray (size arr) $ bData bArr + return $ castArrayToVector $ bData bArr , do Refl <- eqT :: Maybe (r :~: N) bArr <- gcastArr arr - return $ vectorFromArray (size arr) $ nData bArr + return $ castArrayToVector $ bData $ bArray bArr ] {-# NOINLINE castToVector #-} diff --git a/src/Data/Massiv/Array/Mutable.hs b/src/Data/Massiv/Array/Mutable.hs --- a/src/Data/Massiv/Array/Mutable.hs +++ b/src/Data/Massiv/Array/Mutable.hs @@ -1,11 +1,8 @@ -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MagicHash #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UnboxedTuples #-} -- | -- Module : Data.Massiv.Array.Mutable -- Copyright : (c) Alexey Kuleshevich 2018 @@ -51,22 +48,9 @@ import Data.Massiv.Array.Manifest.Internal import Data.Massiv.Array.Unsafe import Data.Massiv.Core.Common ---import GHC.Base (Int (..)) import GHC.Prim --- errorSizeMismatch fName sz1 sz2 = --- error $ fName ++ ": Size mismatch: " ++ show sz1 ++ " /= " ++ show sz2 --- -- TODO: make sure copy is done in parallel as well as sequentially --- copy mTargetArr sourceArr = do --- unless (msize mTargetArr == size sourceArr) $ --- errorSizeMismatch "Data.Massiv.Array.Mutable.copy" (msize mTargetArr) (size sourceArr) --- mSourdceArray <- unsafeThaw sourceArray --- -- comp from marr --- -- TODO: use load --- imapM_ (unsafeWrite) - - -- | Initialize a new mutable array. Negative size will result in an empty array. new :: (Mutable r ix e, PrimMonad m) => ix -> m (MArray (PrimState m) r ix e) new sz = unsafeNewZero (liftIndex (max 0) sz) @@ -79,7 +63,7 @@ -- | /O(n)/ - Yield an immutable copy of the mutable array freeze :: (Mutable r ix e, PrimMonad m) => Comp -> MArray (PrimState m) r ix e -> m (Array r ix e) -freeze comp marr = unsafeFreeze comp marr >>= (return . clone) +freeze comp marr = clone <$> unsafeFreeze comp marr {-# INLINE freeze #-} @@ -174,7 +158,8 @@ else ix1 {-# INLINE swap' #-} -{- +{- Disabled until better times. See https://github.com/lehins/massiv/issues/24 + unsafeLinearFillM :: (Mutable r ix e, Monad m) => MArray RealWorld r ix e -> (Int -> m e) -> WorldState -> m WorldState unsafeLinearFillM ma f (State s_#) = go 0# s_# @@ -281,7 +266,7 @@ -} -{- +{- Disabled until better times Functions in this section can monadically generate manifest arrays using their associated mutable interface. Due to the sequential nature of monads generation is done also sequentially regardless of diff --git a/src/Data/Massiv/Array/Ops/Fold.hs b/src/Data/Massiv/Array/Ops/Fold.hs --- a/src/Data/Massiv/Array/Ops/Fold.hs +++ b/src/Data/Massiv/Array/Ops/Fold.hs @@ -86,7 +86,7 @@ => (e -> m) -- ^ Convert each element of an array to an appropriate `Monoid`. -> Array r ix e -- ^ Source array -> m -foldMono f = foldl mappend mempty mappend mempty . map f +foldMono f = foldlInternal mappend mempty mappend mempty . map f {-# INLINE foldMono #-} @@ -99,7 +99,7 @@ -> m -- ^ Initial element that must be neutral to the (`<>`) function. -> Array r ix e -- ^ Source array -> m -foldSemi f m = foldl (<>) m (<>) m . map f +foldSemi f m = foldlInternal (<>) m (<>) m . map f {-# INLINE foldSemi #-} @@ -154,13 +154,13 @@ -- | Determines whether all element of the array satisfy the predicate. all :: Source r ix e => (e -> Bool) -> Array r ix e -> Bool -all f = foldl (\acc el -> acc && f el) True (&&) True +all f = foldlInternal (\acc el -> acc && f el) True (&&) True {-# INLINE all #-} -- | Determines whether any element of the array satisfies the predicate. any :: Source r ix e => (e -> Bool) -> Array r ix e -> Bool -any f = foldl (\acc el -> acc || f el) False (||) False +any f = foldlInternal (\acc el -> acc || f el) False (||) False {-# INLINE any #-} diff --git a/src/Data/Massiv/Array/Ops/Fold/Internal.hs b/src/Data/Massiv/Array/Ops/Fold/Internal.hs --- a/src/Data/Massiv/Array/Ops/Fold/Internal.hs +++ b/src/Data/Massiv/Array/Ops/Fold/Internal.hs @@ -28,7 +28,7 @@ , ifoldrM_ --Special folds , fold - , foldl + , foldlInternal , foldrFB , lazyFoldlS , lazyFoldrS @@ -66,7 +66,7 @@ -- function. -> Array r ix e -- ^ Source array -> e -fold f initAcc = foldl f initAcc f initAcc +fold f initAcc = foldlInternal f initAcc f initAcc {-# INLINE fold #-} @@ -227,10 +227,10 @@ let !sz = size arr results <- divideWork wIds sz $ \ !scheduler !chunkLength !totalLength !slackStart -> do - loopM_ 0 (< slackStart) (+ chunkLength) $ \ !start -> do - scheduleWork scheduler $ - iterLinearM sz start (start + chunkLength) 1 (<) initAcc $ \ !i ix !acc -> - f acc ix (unsafeLinearIndex arr i) + loopM_ 0 (< slackStart) (+ chunkLength) $ \ !start -> + scheduleWork scheduler $ + iterLinearM sz start (start + chunkLength) 1 (<) initAcc $ \ !i ix !acc -> + f acc ix (unsafeLinearIndex arr i) when (slackStart < totalLength) $ scheduleWork scheduler $ iterLinearM sz slackStart totalLength 1 (<) initAcc $ \ !i ix !acc -> @@ -343,10 +343,10 @@ -- | This folding function breaks referencial transparency on some functions -- @f@, therefore it is kept here for internal use only. -foldl :: Source r ix e => +foldlInternal :: Source r ix e => (a -> e -> a) -> a -> (b -> a -> b) -> b -> Array r ix e -> b -foldl g initAcc f resAcc = \ arr -> +foldlInternal g initAcc f resAcc = \ arr -> case getComp arr of Seq -> f resAcc (foldlS g initAcc arr) ParOn wIds -> unsafePerformIO $ foldlOnP wIds g initAcc f resAcc arr -{-# INLINE foldl #-} +{-# INLINE foldlInternal #-} diff --git a/src/Data/Massiv/Array/Stencil.hs b/src/Data/Massiv/Array/Stencil.hs --- a/src/Data/Massiv/Array/Stencil.hs +++ b/src/Data/Massiv/Array/Stencil.hs @@ -1,7 +1,6 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RecordWildCards #-} -- | -- Module : Data.Massiv.Array.Stencil -- Copyright : (c) Alexey Kuleshevich 2018 @@ -41,10 +40,14 @@ DWArray (DArray (getComp arr) sz (unValue . stencilF (Value . borderIndex b arr))) (Just sSz) - sCenter - (liftIndex2 (-) sz (liftIndex2 (-) sSz (pureIndex 1))) - (unValue . stencilF (Value . unsafeIndex arr)) + (Just window) where + !window = + Window + { windowStart = sCenter + , windowSize = liftIndex2 (-) sz (liftIndex2 (-) sSz (pureIndex 1)) + , windowIndex = unValue . stencilF (Value . unsafeIndex arr) + } !sz = size arr {-# INLINE mapStencil #-} @@ -85,7 +88,7 @@ validateStencil def $ Stencil sSz sCenter stencil where stencil getVal !ix = - (inline relStencil $ \ !ixD -> getVal (liftIndex2 (+) ix ixD)) + inline relStencil $ \ !ixD -> getVal (liftIndex2 (+) ix ixD) {-# INLINE stencil #-} {-# INLINE makeStencil #-} diff --git a/src/Data/Massiv/Array/Stencil/Convolution.hs b/src/Data/Massiv/Array/Stencil/Convolution.hs --- a/src/Data/Massiv/Array/Stencil/Convolution.hs +++ b/src/Data/Massiv/Array/Stencil/Convolution.hs @@ -40,13 +40,10 @@ -> ix -> ((ix -> Value e -> Value e -> Value e) -> Value e -> Value e) -> Stencil ix e e -makeConvolutionStencil !sSz !sCenter relStencil = - validateStencil 0 $ Stencil sSz sCenter stencil +makeConvolutionStencil !sSz !sCenter relStencil = validateStencil 0 $ Stencil sSz sCenter stencil where stencil getVal !ix = - ((inline relStencil $ \ !ixD !kVal !acc -> - (getVal (liftIndex2 (-) ix ixD)) * kVal + acc) - 0) + (inline relStencil $ \ !ixD !kVal !acc -> getVal (liftIndex2 (-) ix ixD) * kVal + acc) 0 {-# INLINE stencil #-} {-# INLINE makeConvolutionStencil #-} @@ -61,7 +58,7 @@ makeConvolutionStencilFromKernel kArr = Stencil sz sCenter stencil where !sz = size kArr - !sCenter = (liftIndex (`div` 2) sz) + !sCenter = liftIndex (`div` 2) sz stencil getVal !ix = Value (ifoldlS accum 0 kArr) where accum !acc !kIx !kVal = unValue (getVal (liftIndex2 (+) ix (liftIndex2 (-) sCenter kIx))) * kVal + acc @@ -78,13 +75,10 @@ -> ix -> ((ix -> Value e -> Value e -> Value e) -> Value e -> Value e) -> Stencil ix e e -makeCorrelationStencil !sSz !sCenter relStencil = - validateStencil 0 $ Stencil sSz sCenter stencil +makeCorrelationStencil !sSz !sCenter relStencil = validateStencil 0 $ Stencil sSz sCenter stencil where stencil getVal !ix = - ((inline relStencil $ \ !ixD !kVal !acc -> - (getVal (liftIndex2 (+) ix ixD)) * kVal + acc) - 0) + (inline relStencil $ \ !ixD !kVal !acc -> getVal (liftIndex2 (+) ix ixD) * kVal + acc) 0 {-# INLINE stencil #-} {-# INLINE makeCorrelationStencil #-} @@ -99,7 +93,7 @@ makeCorrelationStencilFromKernel kArr = Stencil sz sCenter stencil where !sz = size kArr - !sCenter = (liftIndex (`div` 2) sz) + !sCenter = liftIndex (`div` 2) sz stencil getVal !ix = Value (ifoldlS accum 0 kArr) where accum !acc !kIx !kVal = unValue (getVal (liftIndex2 (+) ix (liftIndex2 (+) sCenter kIx))) * kVal + acc diff --git a/src/Data/Massiv/Array/Stencil/Internal.hs b/src/Data/Massiv/Array/Stencil/Internal.hs --- a/src/Data/Massiv/Array/Stencil/Internal.hs +++ b/src/Data/Massiv/Array/Stencil/Internal.hs @@ -33,7 +33,7 @@ , stencilFunc :: (ix -> Value e) -> ix -> Value a } -instance (NFData e, Index ix) => NFData (Stencil ix e a) where +instance Index ix => NFData (Stencil ix e a) where rnf (Stencil sz ix f) = sz `deepseq` ix `deepseq` f `seq` () -- | This is a simple wrapper for value of an array cell. It is used in order to improve safety of @@ -221,7 +221,7 @@ safeStencilIndex :: Index ix => Array D ix e -> ix -> e safeStencilIndex DArray {..} ix - | isSafeIndex dSize ix = dUnsafeIndex ix + | isSafeIndex dSize ix = dIndex ix | otherwise = error $ "Index is out of bounds: " ++ show ix ++ " for stencil size: " ++ show dSize diff --git a/src/Data/Massiv/Array/Stencil/Unsafe.hs b/src/Data/Massiv/Array/Stencil/Unsafe.hs --- a/src/Data/Massiv/Array/Stencil/Unsafe.hs +++ b/src/Data/Massiv/Array/Stencil/Unsafe.hs @@ -16,7 +16,7 @@ ) where import Data.Massiv.Core.Common -import Data.Massiv.Array.Delayed.Windowed +import Data.Massiv.Array.Delayed.Windowed (Window(..), DW, Array(..)) import GHC.Exts (inline) @@ -44,11 +44,15 @@ DWArray (DArray (getComp arr) sz (stencil (index arr))) (Just sSz) - sCenter - (liftIndex2 (-) sz (liftIndex2 (-) sSz (pureIndex 1))) - (stencil (Just . unsafeIndex arr)) + (Just window) where - stencil getVal !ix = (inline relStencil $ \ !ixD -> getVal (liftIndex2 (+) ix ixD)) + !window = + Window + { windowStart = sCenter + , windowSize = liftIndex2 (-) sz (liftIndex2 (-) sSz (pureIndex 1)) + , windowIndex = stencil (Just . unsafeIndex arr) + } + stencil getVal !ix = inline relStencil $ \ !ixD -> getVal (liftIndex2 (+) ix ixD) {-# INLINE stencil #-} !sz = size arr {-# INLINE forStencilUnsafe #-} diff --git a/src/Data/Massiv/Core.hs b/src/Data/Massiv/Core.hs --- a/src/Data/Massiv/Core.hs +++ b/src/Data/Massiv/Core.hs @@ -49,7 +49,7 @@ , isEmpty ) where -import Data.Massiv.Core.Common hiding (unsafeGenerateM) +import Data.Massiv.Core.Common hiding (indexWith, unsafeGenerateM) import Data.Massiv.Core.List import Data.Massiv.Core.Index diff --git a/src/Data/Massiv/Core/Common.hs b/src/Data/Massiv/Core/Common.hs --- a/src/Data/Massiv/Core/Common.hs +++ b/src/Data/Massiv/Core/Common.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MagicHash #-} @@ -37,6 +38,7 @@ -- * Indexing , (!?) , index + , indexWith , (!) , index' , (??) @@ -52,9 +54,12 @@ import Control.Monad.Primitive import Data.Massiv.Core.Computation import Data.Massiv.Core.Index +import Data.Massiv.Core.Scheduler import Data.Typeable import GHC.Prim +#include "massiv.h" + -- | The array family. Representations @r@ describes how data is arranged or computed. All arrays -- have a common property that each index @ix@ always maps to the same unique element, even if that -- element does not exist in memory and has to be computed upon lookup. Data is always arranged in a @@ -103,7 +108,9 @@ -- | Lookup element in the array. No bounds check is performed and access of -- arbitrary memory is possible when invalid index is supplied. unsafeIndex :: Array r ix e -> ix -> e - unsafeIndex !arr = unsafeLinearIndex arr . toLinearIndex (size arr) + unsafeIndex = + INDEX_CHECK("(Source r ix e).unsafeIndex", + size, \ !arr -> unsafeLinearIndex arr . toLinearIndex (size arr)) {-# INLINE unsafeIndex #-} -- | Lookup element in the array using flat index in a row-major fasion. No @@ -114,6 +121,7 @@ -- | Any array that can be computed class Size r ix e => Load r ix e where + -- | Load an array into memory sequentially loadS :: Monad m => @@ -121,6 +129,8 @@ -> (Int -> m e) -- ^ Function that reads an element from target array -> (Int -> e -> m ()) -- ^ Function that writes an element into target array -> m () + loadS = loadArray 1 id + {-# INLINE loadS #-} -- | Load an array into memory in parallel loadP @@ -131,7 +141,68 @@ -> (Int -> IO e) -- ^ Function that reads an element from target array -> (Int -> e -> IO ()) -- ^ Function that writes an element into target array -> IO () + loadP wIds arr unsafeRead unsafeWrite = + withScheduler_ wIds $ \scheduler -> + loadArray (numWorkers scheduler) (scheduleWork scheduler) arr unsafeRead unsafeWrite + {-# INLINE loadP #-} + -- | Load an array into memory with stride. Default implementation can only handle the sequential + -- case and only if there is an instance of `Source`. + loadArrayWithStride + :: Monad m => + Int -- ^ Total number of workers (for `Seq` it's always 1) + -> (m () -> m ()) -- ^ A monadic action that will schedule work for the workers (for `Seq` it's + -- always `id`) + -> Stride ix -- ^ Stride to use + -> ix -- ^ Size of the target array affected by the stride. + -> Array r ix e -- ^ Array that is being loaded + -> (Int -> m e) -- ^ Function that reads an element from target array + -> (Int -> e -> m ()) -- ^ Function that writes an element into target array + -> m () + default loadArrayWithStride + :: (Source r ix e, Monad m) => + Int + -> (m () -> m ()) + -> Stride ix + -> ix + -> Array r ix e + -> (Int -> m e) + -> (Int -> e -> m ()) + -> m () + loadArrayWithStride numWorkers' scheduleWork' stride resultSize arr _ = + splitLinearlyWith_ numWorkers' scheduleWork' (totalElem resultSize) unsafeLinearWriteWithStride + where + strideIx = unStride stride + unsafeLinearWriteWithStride = + unsafeIndex arr . liftIndex2 (*) strideIx . fromLinearIndex resultSize + {-# INLINE unsafeLinearWriteWithStride #-} + {-# INLINE loadArrayWithStride #-} + + -- TODO: this is the future replacement for loadS and loadP discussed in: + -- https://github.com/lehins/massiv/issues/41 + -- | Load an array into memory. Default implementation will respect the scheduler and use `Source` + -- instance to do loading in row-major fashion in parallel as well as sequentially. + loadArray + :: Monad m => + Int -- ^ Total number of workers (for `Seq` it's always 1) + -> (m () -> m ()) -- ^ A monadic action that will schedule work for the workers (for `Seq` it's + -- always `id`) + -> Array r ix e -- ^ Array that is being loaded + -> (Int -> m e) -- ^ Function that reads an element from target array + -> (Int -> e -> m ()) -- ^ Function that writes an element into target array + -> m () + default loadArray + :: (Source r ix e, Monad m) => + Int + -> (m () -> m ()) + -> Array r ix e + -> (Int -> m e) + -> (Int -> e -> m ()) + -> m () + loadArray numWorkers' scheduleWork' arr _ = + splitLinearlyWith_ numWorkers' scheduleWork' (totalElem (size arr)) (unsafeLinearIndex arr) + {-# INLINE loadArray #-} + class OuterSlice r ix e where -- | /O(1)/ - Take a slice out of an array from the outside unsafeOuterSlice :: Array r ix e -> Int -> Elt r ix e @@ -243,8 +314,6 @@ edgeSize :: Array r ix e -> ix - --outerLength :: Array r ix e -> Int - flatten :: Array r ix e -> Array r Ix1 e loadRagged :: @@ -348,6 +417,28 @@ ix {-# INLINE evaluateAt #-} + +indexWith :: + Index ix + => String -- ^ Source file name, eg. __FILE__ + -> Int -- ^ Line number in th source file, eg. __LINE__ + -> String + -> (arr -> ix) -- ^ Get size of the array + -> (arr -> ix -> e) -- ^ Indexing function + -> arr -- ^ Array + -> ix -- ^ Index + -> e +indexWith fileName lineNo funName getSize f arr ix + | isSafeIndex (getSize arr) ix = f arr ix + | otherwise = errorIx ("<" ++ fileName ++ ":" ++ show lineNo ++ "> " ++ funName) (getSize arr) ix +{-# INLINE indexWith #-} + + +-- indexWith :: Size r ix e => String -> Int -> (Array r ix e -> ix -> e) -> Array r ix e -> ix -> e +-- indexWith fileName lineNo f arr ix +-- | isSafeIndex (size arr) ix = f arr ix +-- | otherwise = errorIx ("<" ++ fileName ++ ":" ++ show lineNo ++ "> indexWith") (size arr) ix +-- {-# INLINE indexWith #-} -- errorImpossible :: String -> a -- errorImpossible loc = diff --git a/src/Data/Massiv/Core/Index.hs b/src/Data/Massiv/Core/Index.hs --- a/src/Data/Massiv/Core/Index.hs +++ b/src/Data/Massiv/Core/Index.hs @@ -1,10 +1,5 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE PatternSynonyms #-} -- | -- Module : Data.Massiv.Core.Index -- Copyright : (c) Alexey Kuleshevich 2018 @@ -15,9 +10,17 @@ -- module Data.Massiv.Core.Index ( module Data.Massiv.Core.Index.Ix + , Stride + , pattern Stride + , unStride + , toLinearIndexStride + , strideStart + , strideSize + , oneStride , Border(..) , handleBorderIndex , module Data.Massiv.Core.Index.Class + , zeroIndex , isSafeSize , isNonEmpty , headDim @@ -32,6 +35,7 @@ import Control.DeepSeq import Data.Massiv.Core.Index.Class import Data.Massiv.Core.Index.Ix +import Data.Massiv.Core.Index.Stride import Data.Massiv.Core.Iterator @@ -105,7 +109,10 @@ (\ !k !i -> (-i - 2) `mod` k)) {-# INLINE [1] handleBorderIndex #-} - +-- | Index with all zeros +zeroIndex :: Index ix => ix +zeroIndex = pureIndex 0 +{-# INLINE [1] zeroIndex #-} -- | Checks whether the size is valid. isSafeSize :: Index ix => ix -> Bool @@ -136,7 +143,8 @@ {-# INLINE [1] initDim #-} --- | Iterate over N-dimensional space from start to end with accumulator +-- | Iterate over N-dimensional space lenarly from start to end in row-major fashion with an +-- accumulator iterLinearM :: (Index ix, Monad m) => ix -- ^ Size -> Int -- ^ Linear start @@ -150,6 +158,7 @@ loopM k0 (`cond` k1) (+ inc) acc $ \ !i !acc0 -> f i (fromLinearIndex sz i) acc0 {-# INLINE iterLinearM #-} +-- | Same as `iterLinearM`, except without an accumulator. iterLinearM_ :: (Index ix, Monad m) => ix -- ^ Size -> Int -- ^ Start @@ -161,4 +170,3 @@ iterLinearM_ !sz !k0 !k1 !inc cond f = loopM_ k0 (`cond` k1) (+ inc) $ \ !i -> f i (fromLinearIndex sz i) {-# INLINE iterLinearM_ #-} - diff --git a/src/Data/Massiv/Core/Index/Class.hs b/src/Data/Massiv/Core/Index/Class.hs --- a/src/Data/Massiv/Core/Index/Class.hs +++ b/src/Data/Massiv/Core/Index/Class.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE DataKinds #-} {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -92,16 +92,18 @@ -- | Zip together two indices with a function liftIndex2 :: (Int -> Int -> Int) -> ix -> ix -> ix - -- | Index with all zeros - zeroIndex :: ix - zeroIndex = pureIndex 0 - {-# INLINE [1] zeroIndex #-} - -- | Map a function over an index liftIndex :: (Int -> Int) -> ix -> ix - liftIndex f = liftIndex2 (\_ i -> f i) zeroIndex + liftIndex f = liftIndex2 (\_ i -> f i) (pureIndex 0) {-# INLINE [1] liftIndex #-} + foldlIndex :: (a -> Int -> a) -> a -> ix -> a + default foldlIndex :: Index (Lower ix) => (a -> Int -> a) -> a -> ix -> a + foldlIndex f !acc !ix = foldlIndex f (f acc i0) ixL + where + !(i0, ixL) = unconsDim ix + {-# INLINE [1] foldlIndex #-} + -- | Check whether index is within the size. isSafeIndex :: ix -- ^ Size -> ix -- ^ Index @@ -191,6 +193,7 @@ !(inc, incIxL) = unconsDim incIx {-# INLINE iterM #-} + -- TODO: Implement in terms of iterM, benchmark it and remove from `Index` -- | Same as `iterM`, but don't bother with accumulator and return value. iterM_ :: Monad m => ix -> ix -> ix -> (Int -> Int -> Bool) -> (ix -> m a) -> m () default iterM_ :: (Index (Lower ix), Monad m) @@ -250,6 +253,8 @@ {-# INLINE [1] liftIndex #-} liftIndex2 f = f {-# INLINE [1] liftIndex2 #-} + foldlIndex f = f + {-# INLINE [1] foldlIndex #-} iter k0 k1 inc cond = loop k0 (`cond` k1) (+inc) {-# INLINE iter #-} iterM k0 k1 inc cond = loopM k0 (`cond` k1) (+inc) @@ -262,9 +267,9 @@ type Dimensions Ix2T = 2 dimensions _ = 2 {-# INLINE [1] dimensions #-} - totalElem !(m, n) = m * n + totalElem (m, n) = m * n {-# INLINE [1] totalElem #-} - toLinearIndex !(_, n) !(i, j) = n * i + j + toLinearIndex (_, n) (i, j) = n * i + j {-# INLINE [1] toLinearIndex #-} fromLinearIndex (_, n) !k = k `quotRem` n {-# INLINE [1] fromLinearIndex #-} @@ -413,7 +418,7 @@ errorIx fName sz ix = error $ fName ++ - ": Index out of bounds: " ++ show ix ++ " for Array of size: " ++ show sz + ": Index out of bounds: (" ++ show ix ++ ") for Array of size: (" ++ show sz ++ ")" {-# NOINLINE errorIx #-} diff --git a/src/Data/Massiv/Core/Index/Ix.hs b/src/Data/Massiv/Core/Index/Ix.hs --- a/src/Data/Massiv/Core/Index/Ix.hs +++ b/src/Data/Massiv/Core/Index/Ix.hs @@ -535,7 +535,7 @@ {-# INLINE basicUnsafeThaw #-} basicLength (V_IxN (_, vec)) = V.basicLength vec {-# INLINE basicLength #-} - basicUnsafeSlice idx len (V_IxN (vec1, vec)) = do + basicUnsafeSlice idx len (V_IxN (vec1, vec)) = V_IxN (V.basicUnsafeSlice idx len vec1, V.basicUnsafeSlice idx len vec) {-# INLINE basicUnsafeSlice #-} basicUnsafeIndexM (V_IxN (vec1, vec)) idx = do diff --git a/src/Data/Massiv/Core/Index/Stride.hs b/src/Data/Massiv/Core/Index/Stride.hs new file mode 100644 --- /dev/null +++ b/src/Data/Massiv/Core/Index/Stride.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE PatternSynonyms #-} + +#if __GLASGOW_HASKELL__ >= 800 +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +#else +{-# LANGUAGE GADTs #-} +{-# LANGUAGE StandaloneDeriving #-} +#endif +-- | +-- Module : Data.Massiv.Core.Index.Stride +-- Copyright : (c) Alexey Kuleshevich 2018 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- +module Data.Massiv.Core.Index.Stride + ( Stride(SafeStride) + , pattern Stride + , unStride + , oneStride + , toLinearIndexStride + , strideStart + , strideSize + ) where + +import Control.DeepSeq +import Data.Massiv.Core.Index.Class + +-- | Stride provides a way to ignore elements of an array if an index is divisible by a +-- corresponding value in a stride. So, for a @Stride (i :. j)@ only elements with indices will be +-- kept around: +-- +-- @ +-- ( 0 :. 0) ( 0 :. j) ( 0 :. 2j) ( 0 :. 3j) ... +-- ( i :. 0) ( i :. j) ( i :. 2j) ( i :. 3j) ... +-- (2i :. 0) (2i :. j) (2i :. 2j) (2i :. 3j) ... +-- ... +-- @ +-- +-- Only positive strides make sense, so `Stride` pattern synonym constructor will prevent a user +-- from creating a stride with negative or zero values, thus promoting safety of the library. +-- +-- ====__Examples:__ +-- +-- * Default and minimal stride of @`Stride` (`pureIndex` 1)@ will have no affect and all elements +-- will kept. +-- +-- * If stride is @`Stride` 2@, then every 2nd element (i.e. with index 1, 3, 5, ..) will be skipped +-- and only elemnts with indices divisible by 2 will be kept around. +-- +-- * In case of two dimensions, if what you want is to keep all rows divisible by 5, but keep every +-- column intact then you'd use @Stride (5 :. 1)@. +-- + +#if __GLASGOW_HASKELL__ >= 800 +newtype Stride ix = SafeStride ix deriving (Eq, Ord, NFData) +#else +-- There is an issue in GHC 7.10 which prevents from placing `Index` constraint on a pattern. +data Stride ix where + SafeStride :: Index ix => ix -> Stride ix + +deriving instance Eq ix => Eq (Stride ix) +deriving instance Ord ix => Ord (Stride ix) +instance NFData ix => NFData (Stride ix) where + rnf (SafeStride ix) = rnf ix +#endif + + +instance Index ix => Show (Stride ix) where + show (SafeStride ix) = "Stride (" ++ show ix ++ ")" + + +-- | A safe bidirectional pattern synonym for `Stride` construction that will make sure stride +-- elements are always positive. +pattern Stride :: Index ix => ix -> Stride ix +pattern Stride ix <- SafeStride ix where + Stride ix = SafeStride (liftIndex (max 1) ix) + +-- | Just a helper function for unwrapping `Stride`. +unStride :: Stride ix -> ix +unStride (SafeStride ix) = ix +{-# INLINE unStride #-} + +-- | Adjust strating index according to the stride +strideStart :: Index ix => Stride ix -> ix -> ix +strideStart (SafeStride stride) ix = + liftIndex2 + (+) + ix + (liftIndex2 mod (liftIndex2 subtract (liftIndex2 mod ix stride) stride) stride) +{-# INLINE strideStart #-} + +-- | Adjust size according to the stride. +strideSize :: Index ix => Stride ix -> ix -> ix +strideSize (SafeStride stride) sz = liftIndex (+ 1) $ liftIndex2 div (liftIndex (subtract 1) sz) stride +{-# INLINE strideSize #-} + +-- | Compute an index with stride using the original size and index +toLinearIndexStride :: Index ix => + Stride ix -- ^ Stride + -> ix -- ^ Size + -> ix -- ^ Index + -> Int +toLinearIndexStride (SafeStride stride) sz ix = toLinearIndex sz (liftIndex2 div ix stride) +{-# INLINE toLinearIndexStride #-} + + +-- | A default stride of @1@, where all elements are kept +oneStride :: Index ix => Stride ix +oneStride = SafeStride (pureIndex 1) +{-# INLINE oneStride #-} + + diff --git a/src/Data/Massiv/Core/Iterator.hs b/src/Data/Massiv/Core/Iterator.hs --- a/src/Data/Massiv/Core/Iterator.hs +++ b/src/Data/Massiv/Core/Iterator.hs @@ -12,6 +12,8 @@ , loopM , loopM_ , loopDeepM + , splitLinearly + , splitLinearlyWith_ ) where @@ -58,3 +60,21 @@ False -> return acc True -> go (increment step) acc >>= f step {-# INLINE loopDeepM #-} + + + +splitLinearly :: Int -> Int -> (Int -> Int -> a) -> a +splitLinearly numChunks totalLength action = action chunkLength slackStart + where + !chunkLength = totalLength `quot` numChunks + !slackStart = chunkLength * numChunks +{-# INLINE splitLinearly #-} + + +splitLinearlyWith_ :: Monad m => Int -> (m () -> m a) -> Int -> (Int -> b) -> (Int -> b -> m ()) -> m a +splitLinearlyWith_ numChunks with totalLength index write = + splitLinearly numChunks totalLength $ \chunkLength slackStart -> do + loopM_ 0 (< slackStart) (+ chunkLength) $ \ !start -> + with $ loopM_ start (< (start + chunkLength)) (+ 1) $ \ !k -> write k (index k) + with $ loopM_ slackStart (< totalLength) (+ 1) $ \ !k -> write k (index k) +{-# INLINE splitLinearlyWith_ #-} diff --git a/src/Data/Massiv/Core/List.hs b/src/Data/Massiv/Core/List.hs --- a/src/Data/Massiv/Core/List.hs +++ b/src/Data/Massiv/Core/List.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE BangPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -146,7 +146,7 @@ Just (y, ys) -> uWrite i y >> return ys unless (isNull leftOver) $ throwIO RowTooLongError {-# INLINE loadRagged #-} - raggedFormat f _ arr = L.concat $ "[ " : (L.intersperse "," $ map f (coerce (lData arr))) ++ [" ]"] + raggedFormat f _ arr = L.concat $ "[ " : L.intersperse "," (map f (coerce (lData arr))) ++ [" ]"] instance ( Index ix @@ -251,24 +251,23 @@ unsafeGenerateParM wws !sz f = do res <- sequence $ unsafePerformIO $ do let !(k, szL) = unconsDim sz - resLs <- divideWork wws k $ \ !scheduler !chunkLength !totalLength !slackStart -> do - loopM_ 0 (< slackStart) (+ chunkLength) $ \ !start -> do - scheduleWork scheduler $ do - -- res <- loopM (start + chunkLength - 1) (>= start) (subtract 1) [] $ \i acc -> do - -- return (fmap lData (unsafeGenerateM Seq szL (\ !ixL -> f (consDim i ixL))):acc) - -- return $! sequence res - res <- loopDeepM start (< (start + chunkLength)) (+ 1) [] $ \i acc -> do - return (fmap lData (unsafeGenerateM Seq szL (\ !ixL -> f (consDim i ixL))):acc) - return $! sequence res - when (slackStart < totalLength) $ - scheduleWork scheduler $ do - -- res <- loopM (totalLength - 1) (>= slackStart) (subtract 1) [] $ \i acc -> do - -- return (fmap lData (unsafeGenerateM Seq szL (\ !ixL -> f (consDim i ixL))):acc) - -- return $! sequence res - res <- loopDeepM slackStart (< totalLength) (+ 1) [] $ \i acc -> do - return (fmap lData (unsafeGenerateM Seq szL (\ !ixL -> f (consDim i ixL))):acc) - return $! sequence res - return resLs + divideWork wws k $ \ !scheduler !chunkLength !totalLength !slackStart -> do + loopM_ 0 (< slackStart) (+ chunkLength) $ \ !start -> + scheduleWork scheduler $ do + -- res <- loopM (start + chunkLength - 1) (>= start) (subtract 1) [] $ \i acc -> do + -- return (fmap lData (unsafeGenerateM Seq szL (\ !ixL -> f (consDim i ixL))):acc) + -- return $! sequence res + res <- loopDeepM start (< (start + chunkLength)) (+ 1) [] $ \i acc -> + return (fmap lData (unsafeGenerateM Seq szL (\ !ixL -> f (consDim i ixL))):acc) + return $! sequence res + when (slackStart < totalLength) $ + scheduleWork scheduler $ do + -- res <- loopM (totalLength - 1) (>= slackStart) (subtract 1) [] $ \i acc -> do + -- return (fmap lData (unsafeGenerateM Seq szL (\ !ixL -> f (consDim i ixL))):acc) + -- return $! sequence res + res <- loopDeepM slackStart (< totalLength) (+ 1) [] $ \i acc -> + return (fmap lData (unsafeGenerateM Seq szL (\ !ixL -> f (consDim i ixL))):acc) + return $! sequence res return $ LArray (ParOn wws) $ List $ concat res {-# INLINE unsafeGenerateParM #-} @@ -305,7 +304,7 @@ setComp c arr = arr { lComp = c } {-# INLINE setComp #-} unsafeMakeArray Seq sz f = runIdentity $ unsafeGenerateM Seq sz (return . f) - unsafeMakeArray (ParOn wss) sz f = LArray (ParOn wss) $ List $ unsafePerformIO $ do + unsafeMakeArray (ParOn wss) sz f = LArray (ParOn wss) $ List $ unsafePerformIO $ withScheduler' wss $ \scheduler -> loopM_ 0 (< sz) (+ 1) (scheduleWork scheduler . return . f) {-# INLINE unsafeMakeArray #-} @@ -321,13 +320,12 @@ {-# INLINE getComp #-} setComp c arr = arr {lComp = c} {-# INLINE setComp #-} - unsafeMakeArray comp sz f = unsafeGenerateN comp sz f + unsafeMakeArray = unsafeGenerateN {-# INLINE unsafeMakeArray #-} -- TODO: benchmark against using unsafeGenerateM directly unsafeGenerateN :: - ( Index ix - , Ragged r ix e + ( Ragged r ix e , Ragged r (Lower ix) e , Elt r ix e ~ Array r (Lower ix) e ) => Comp @@ -337,8 +335,8 @@ unsafeGenerateN Seq sz f = runIdentity $ unsafeGenerateM Seq sz (return . f) unsafeGenerateN c@(ParOn wss) sz f = unsafePerformIO $ do let !(m, szL) = unconsDim sz - xs <- withScheduler' wss $ \scheduler -> do - loopM_ 0 (< m) (+ 1) $ \i -> scheduleWork scheduler $ do + xs <- withScheduler' wss $ \scheduler -> + loopM_ 0 (< m) (+ 1) $ \i -> scheduleWork scheduler $ unsafeGenerateM c szL $ \ix -> return $ f (consDim i ix) return $! foldr' cons (empty c) xs {-# INLINE unsafeGenerateN #-} @@ -356,7 +354,7 @@ instance {-# OVERLAPPING #-} (Ragged L ix e, Show e) => Show (Array L ix e) where show arr = " " ++ raggedFormat show "\n " arr -instance {-# OVERLAPPING #-} (Ragged L ix e, Nested LN ix e, Show e) => +instance {-# OVERLAPPING #-} (Ragged L ix e, Show e) => Show (Array LN ix e) where show arr = show (fromNested arr :: Array L ix e) @@ -366,25 +364,19 @@ showN fShow lnPrefix ls = L.concat (["[ "] ++ - (L.intersperse (lnPrefix ++ ", ") $ map (fShow (lnPrefix ++ " ")) ls) ++ [lnPrefix, "]"]) + L.intersperse (lnPrefix ++ ", ") (map (fShow (lnPrefix ++ " ")) ls) ++ [lnPrefix, "]"]) + instance ( Ragged L ix e - , Construct L ix e , Source r ix e , Show e ) => Show (Array r ix e) where - show arr = showArray (showsTypeRep (typeRep (Proxy :: Proxy r)) " ") arr - -- "(Array " ++ showsTypeRep (typeRep (Proxy :: Proxy r)) " " ++ - -- showComp (getComp arr) ++ " (" ++ - -- (show (size arr)) ++ ")\n" ++ - -- show (makeArray (getComp arr) (size arr) (evaluateAt arr) :: Array L ix e) ++ ")" - -- where showComp Seq = "Seq" - -- showComp Par = "Par" - -- showComp c = "(" ++ show c ++ ")" + show = showArray (showsTypeRep (typeRep (Proxy :: Proxy r)) " ") + showArray :: - forall r ix e. (Ragged L ix e, Construct L ix e, Source r ix e, Show e) + forall r ix e. (Ragged L ix e, Source r ix e, Show e) => String -> Array r ix e -> String diff --git a/src/Data/Massiv/Core/Scheduler.hs b/src/Data/Massiv/Core/Scheduler.hs --- a/src/Data/Massiv/Core/Scheduler.hs +++ b/src/Data/Massiv/Core/Scheduler.hs @@ -1,5 +1,4 @@ {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -- | @@ -28,7 +27,7 @@ import Control.Exception (SomeException, catch, mask, mask_, throwIO, try, uninterruptibleMask_) -import Control.Monad (forM) +import Control.Monad (void, forM) import Control.Monad.Primitive (RealWorld) import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef) @@ -44,13 +43,15 @@ | Retire data Scheduler a = Scheduler - { jobsCountIORef :: !(IORef Int) - , jobQueueMVar :: !(MVar [Job]) - , resultsMVar :: !(MVar (MutableArray RealWorld a)) - , workers :: !Workers - , numWorkers :: {-# UNPACK #-} !Int + { jobsCountIORef :: !(IORef Int) + , jobQueueMVar :: !(MVar [Job]) + , resultsMVar :: !(MVar (MutableArray RealWorld a)) + , workers :: !Workers + , numCapabilities :: {-# UNPACK #-} !Int } +numWorkers :: Scheduler a -> Int +numWorkers = numCapabilities data Workers = Workers { workerThreadIds :: ![ThreadId] , workerJobDone :: !(MVar (Maybe SomeException)) @@ -63,7 +64,7 @@ scheduleWork :: Scheduler a -- ^ Scheduler to use -> IO a -- ^ Action to hand of to a worker -> IO () -scheduleWork Scheduler {..} jobAction = do +scheduleWork Scheduler {..} jobAction = modifyMVar_ jobQueueMVar $ \jobs -> do jix <- atomicModifyIORef' jobsCountIORef $ \jc -> (jc + 1, jc) let job = @@ -127,13 +128,13 @@ mGlobalWorkers <- maybe (return Nothing) deRefWeak mWeakWorkers let toWorkers w = return (mWeakWorkers, w) maybe (hireWorkers wss >>= toWorkers) toWorkers mGlobalWorkers) - (\(mWeakWorkers, workers) -> do + (\(mWeakWorkers, workers) -> case mWeakWorkers of Nothing -> putMVar (workerJobQueue workers) $ replicate (length (workerThreadIds workers)) Retire Just weak -> putMVar globalWorkersMVar weak) - (\_ (mWeakWorkers, workers) -> do + (\_ (mWeakWorkers, workers) -> case mWeakWorkers of Nothing -> mapM_ killThread (workerThreadIds workers) Just weakWorkers -> do @@ -142,7 +143,7 @@ putMVar globalWorkersMVar newWeakWorkers) (\(_, workers) -> do let scheduler = - Scheduler {numWorkers = length $ workerThreadIds workers, ..} + Scheduler {numCapabilities = length $ workerThreadIds workers, ..} _ <- submitJobs scheduler jobCount <- readIORef jobsCountIORef marr <- newArray jobCount uninitialized @@ -165,13 +166,13 @@ -- | Just like `withScheduler`, but discards the results. withScheduler_ :: [Int] -> (Scheduler a -> IO b) -> IO () -withScheduler_ wss submitJobs = withScheduler wss submitJobs >> return () +withScheduler_ wss submitJobs = void $ withScheduler wss submitJobs -- | Same as `divideWork`, but discard the result. divideWork_ :: Index ix => [Int] -> ix -> (Scheduler a -> Int -> Int -> Int -> IO b) -> IO () -divideWork_ wss sz submit = divideWork wss sz submit >> return () +divideWork_ wss sz submit = void $ divideWork wss sz submit -- | Linearly (row-major first) and equally divide work among available workers. Submit function @@ -185,7 +186,7 @@ -> IO [a] divideWork wss sz submit | totalElem sz == 0 = return [] - | otherwise = do + | otherwise = withScheduler' wss $ \scheduler -> do let !totalLength = totalElem sz !chunkLength = totalLength `quot` numWorkers scheduler @@ -195,7 +196,7 @@ -- | Wait till workers finished with all submitted jobs, but raise an exception if either of them -- has died. Raised exception is the same one that was the cause of worker's death. waitTillDone :: Scheduler a -> IO () -waitTillDone (Scheduler {..}) = readIORef jobsCountIORef >>= waitTill 0 +waitTillDone Scheduler {..} = readIORef jobsCountIORef >>= waitTill 0 where waitTill jobsDone jobsCount | jobsDone == jobsCount = return () diff --git a/tests/Data/Massiv/Array/Delayed/WindowedSpec.hs b/tests/Data/Massiv/Array/Delayed/WindowedSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Data/Massiv/Array/Delayed/WindowedSpec.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} +module Data.Massiv.Array.Delayed.WindowedSpec (spec) where + +import Data.Massiv.Array.Delayed +import Data.Massiv.Array.Unsafe +import Data.Massiv.CoreArbitrary as A +import Data.Typeable +import Test.Hspec +import Test.QuickCheck + + +data ArrDW ix e = ArrDW (Array D ix e) (Array DW ix e) + +instance (Show ix, Index ix, Show (Array D ix e), Show (Array DW ix e)) => Show (ArrDW ix e) where + show (ArrDW d dw) = + "Delayed:\n" ++ + show d ++ + "\nCorresponding Windowed:\n" ++ + --show dw ++ + windowInfo + where + windowInfo = + maybe + "\n No Window" + (\Window {windowStart, windowSize} -> + "\n With Window starting index (" ++ + show windowStart ++ ") and size (" ++ show windowSize ++ ")") $ + getWindow dw + +instance (Arbitrary ix, CoArbitrary ix, Index ix, Arbitrary e, Typeable e) => + Arbitrary (ArrDW ix e) where + arbitrary = do + ArrTiny (arr :: Array D ix e) <- arbitrary + let sz = size arr + ArrDW arr <$> + if totalElem sz == 0 + then return (unsafeMakeArray (getComp arr) sz (unsafeIndex arr)) + else do + wix <- flip (liftIndex2 mod) sz <$> arbitrary + wsz <- liftIndex (+1) . flip (liftIndex2 mod) (liftIndex2 (-) sz wix) <$> arbitrary + return $ makeWindowedArray arr wix wsz (unsafeIndex arr) + + +prop_EqDelayed :: + (Ragged L ix Int, Load DW ix Int) => Proxy ix -> ArrDW ix Int -> Property +prop_EqDelayed _ (ArrDW arrD arrDW) = + computeAs P arrD === computeAs P arrDW + +prop_EqDelayedStride :: + (Ragged L ix Int, Load DW ix Int) => Proxy ix -> Stride ix -> ArrDW ix Int -> Property +prop_EqDelayedStride _ stride (ArrDW arrD arrDW) = + computeWithStrideAs P stride arrD === computeWithStrideAs P stride arrDW + + +spec :: Spec +spec = do + describe "Equivalency with Delayed" $ do + it "Ix1" $ property $ prop_EqDelayed (Proxy :: Proxy Ix1) + it "Ix2" $ property $ prop_EqDelayed (Proxy :: Proxy Ix2) + it "Ix3" $ property $ prop_EqDelayed (Proxy :: Proxy Ix3) + it "Ix4" $ property $ prop_EqDelayed (Proxy :: Proxy Ix4) + it "Ix5" $ property $ prop_EqDelayed (Proxy :: Proxy Ix5) + it "Ix2T" $ property $ prop_EqDelayed (Proxy :: Proxy Ix2T) + it "Ix3T" $ property $ prop_EqDelayed (Proxy :: Proxy Ix3T) + it "Ix4T" $ property $ prop_EqDelayed (Proxy :: Proxy Ix4T) + it "Ix5T" $ property $ prop_EqDelayed (Proxy :: Proxy Ix5T) + describe "Equivalency with Stride With Delayed" $ do + it "Ix1" $ property $ prop_EqDelayedStride (Proxy :: Proxy Ix1) + it "Ix2" $ property $ prop_EqDelayedStride (Proxy :: Proxy Ix2) + it "Ix3" $ property $ prop_EqDelayedStride (Proxy :: Proxy Ix3) + it "Ix4" $ property $ prop_EqDelayedStride (Proxy :: Proxy Ix4) + it "Ix5" $ property $ prop_EqDelayedStride (Proxy :: Proxy Ix5) + it "Ix2T" $ property $ prop_EqDelayedStride (Proxy :: Proxy Ix2T) + it "Ix3T" $ property $ prop_EqDelayedStride (Proxy :: Proxy Ix3T) + it "Ix4T" $ property $ prop_EqDelayedStride (Proxy :: Proxy Ix4T) + it "Ix5T" $ property $ prop_EqDelayedStride (Proxy :: Proxy Ix5T) diff --git a/tests/Data/Massiv/Array/DelayedSpec.hs b/tests/Data/Massiv/Array/DelayedSpec.hs --- a/tests/Data/Massiv/Array/DelayedSpec.hs +++ b/tests/Data/Massiv/Array/DelayedSpec.hs @@ -3,20 +3,65 @@ {-# LANGUAGE MultiParamTypeClasses #-} module Data.Massiv.Array.DelayedSpec (spec) where +import Data.Massiv.Array.Delayed +import Data.Massiv.Array.Unsafe +import Data.Massiv.Array +import Data.Massiv.CoreArbitrary as A +import Data.Proxy import Test.Hspec ---import Test.QuickCheck +import Test.QuickCheck +downsampleArr :: Source r ix e => Stride ix -> Array r ix e -> Array D ix e +downsampleArr stride arr = + unsafeBackpermute (strideSize stride (size arr)) (liftIndex2 (*) (unStride stride)) arr +prop_computeWithStrideEqDownsample :: + Ragged L ix Int + => proxy ix + -> Stride ix + -> Array D ix Int + -> Property +prop_computeWithStrideEqDownsample _ stride arr = + computeWithStride stride arr === computeAs U (downsampleArr stride arr) + +prop_computeWithStrideInterleavedEqDownsample :: + Ragged L ix Int + => proxy ix + -> Stride ix + -> Array D ix Int + -> Property +prop_computeWithStrideInterleavedEqDownsample _ stride arr = + computeWithStride stride (toInterleaved arr) === computeAs U (downsampleArr stride arr) + +prop_computeWithStrideWindowedEqDownsample :: + (Ragged L ix Int, Load DW ix Int) + => proxy ix + -> Stride ix + -> ArrIx D ix Int + -> Property +prop_computeWithStrideWindowedEqDownsample _ stride (ArrIx arr _) = + computeWithStride stride (makeWindowedArray arr zeroIndex (size arr) (unsafeIndex arr)) === + computeAs U (downsampleArr stride arr) + + +delayedSpec :: + (Arbitrary ix, CoArbitrary ix, Load DW ix Int, Ragged L ix Int) + => String + -> proxy ix + -> SpecWith () +delayedSpec dimName proxy = do + describe dimName $ do + it "computeWithStrideEqDownsample" $ property $ prop_computeWithStrideEqDownsample proxy + it "computeWithStrideInterleavedEqDownsample" $ + property $ prop_computeWithStrideInterleavedEqDownsample proxy + it "computeWithStrideWindowedEqDownsample" $ + property $ prop_computeWithStrideWindowedEqDownsample proxy + spec :: Spec -spec = return () - -- describe "DIM1" $ do - -- specShapeN (Nothing :: Maybe (D, DIM1, Int)) - -- describe "DIM2" $ do - -- specShapeN (Nothing :: Maybe (D, DIM2, Int)) - -- specSliceN (Nothing :: Maybe (D, DIM2, Int)) - -- specSliceDim2 - -- describe "DIM3" $ do - -- specShapeN (Nothing :: Maybe (D, DIM3, Int)) - -- specSliceN (Nothing :: Maybe (D, DIM3, Int)) +spec = do + delayedSpec "Ix1" (Proxy :: Proxy Ix1) + delayedSpec "Ix2" (Proxy :: Proxy Ix2) + delayedSpec "Ix3" (Proxy :: Proxy Ix3) + delayedSpec "Ix4" (Proxy :: Proxy Ix4) diff --git a/tests/Data/Massiv/Array/ManifestSpec.hs b/tests/Data/Massiv/Array/ManifestSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Data/Massiv/Array/ManifestSpec.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE MultiParamTypeClasses #-} +module Data.Massiv.Array.ManifestSpec (spec) where + +import Data.ByteString as S +import Data.ByteString.Builder as S +import Data.ByteString.Lazy as SL +import Data.Massiv.CoreArbitrary as A +import Data.Word (Word8) +import Test.Hspec +import Test.QuickCheck + + +-- ByteString +prop_toFromByteString :: Array P Ix1 Word8 -> Property +prop_toFromByteString arr = toManifest arr === fromByteString (getComp arr) (toByteString arr) + +prop_fromToByteString :: Comp -> [Word8] -> Property +prop_fromToByteString comp ls = bs === toByteString (fromByteString comp bs) + where bs = S.pack ls + +prop_toBuilder :: Array P Ix1 Word8 -> Property +prop_toBuilder arr = bs === SL.toStrict (S.toLazyByteString (toBuilder S.word8 arr)) + where bs = toByteString arr + +conversionSpec :: Spec +conversionSpec = do + describe "ByteString" $ do + it "to/from ByteString" $ property prop_toFromByteString + it "from/to ByteString" $ property prop_fromToByteString + it "toBuilder" $ property prop_toBuilder + + +spec :: Spec +spec = describe "Conversion" conversionSpec diff --git a/tests/Data/Massiv/Array/Ops/ConstructSpec.hs b/tests/Data/Massiv/Array/Ops/ConstructSpec.hs --- a/tests/Data/Massiv/Array/Ops/ConstructSpec.hs +++ b/tests/Data/Massiv/Array/Ops/ConstructSpec.hs @@ -56,18 +56,18 @@ resultLs = toLists (fromLists' comp ls2 :: Array U Ix2 Int) --- prop_excFromToListIx3 :: Comp -> [[[Int]]] -> Property --- prop_excFromToListIx3 comp ls3 = --- if P.null lsL || --- (P.all (head lsL ==) lsL && --- (P.null (head lsLL) || P.and (P.map (P.all (head (head lsLL) ==)) lsLL))) --- then classify True "Expected Success" $ resultLs === ls3 --- else classify True "Expected Failure" $ --- assertSomeException resultLs --- where --- resultLs = toList (fromList' comp ls3 :: Array U Ix3 Int) --- lsL = P.map P.length ls3 --- lsLL = P.map (P.map P.length) ls3 +prop_excFromToListIx3 :: Comp -> [[[Int]]] -> Property +prop_excFromToListIx3 comp ls3 + | P.null (P.concat (P.concat ls3)) = + classify True "Expected Success" $ counterexample (show arr) $ totalElem (size arr) === 0 + | P.all (head lsL ==) lsL && (P.and (P.map (P.all (head (head lsLL) ==)) lsLL)) = + classify True "Expected Success" $ counterexample (show arr) $ resultLs === ls3 + | otherwise = classify True "Expected Failure" $ assertSomeException resultLs + where + arr = fromLists' comp ls3 :: Array U Ix3 Int + resultLs = toLists arr + lsL = P.map P.length ls3 + lsLL = P.map (P.map P.length) ls3 specIx1 :: Spec @@ -89,7 +89,7 @@ specIx3 = do it "toFromList" $ property (prop_toFromList (Proxy :: Proxy Ix3)) it "toFromListIsList" $ property (prop_toFromListIsList (Proxy :: Proxy Ix3)) - --it "excFromToListIx3" $ property prop_excFromToListIx3 + it "excFromToListIx3" $ property prop_excFromToListIx3 spec :: Spec diff --git a/tests/Data/Massiv/Array/StencilSpec.hs b/tests/Data/Massiv/Array/StencilSpec.hs --- a/tests/Data/Massiv/Array/StencilSpec.hs +++ b/tests/Data/Massiv/Array/StencilSpec.hs @@ -6,8 +6,6 @@ module Data.Massiv.Array.StencilSpec (spec) where import Control.DeepSeq (deepseq) -import Data.Massiv.Array.Stencil -import Data.Massiv.Array.Delayed import Data.Massiv.CoreArbitrary as A import Data.Maybe (fromJust) import Data.Proxy @@ -24,16 +22,22 @@ -- {-# INLINE sum3x3Stencil #-} -singletonStencil :: (Num ix, Index ix) => (Int -> Int) -> Stencil ix Int Int -singletonStencil f = makeStencil 1 0 $ \ get -> fmap f (get zeroIndex) +singletonStencil :: (Index ix) => (Int -> Int) -> Stencil ix Int Int +singletonStencil f = makeStencil (pureIndex 1) zeroIndex $ \ get -> fmap f (get zeroIndex) {-# INLINE singletonStencil #-} -prop_MapSingletonStencil :: (Load DW ix Int, Manifest U ix Int, Num ix) => +prop_MapSingletonStencil :: (Load DW ix Int, Manifest U ix Int) => Proxy ix -> Fun Int Int -> Border Int -> ArrP U ix Int -> Bool prop_MapSingletonStencil _ f b (ArrP arr) = computeAs U (mapStencil b (singletonStencil (apply f)) arr) == computeAs U (A.map (apply f) arr) +prop_MapSingletonStencilWithStride :: (Load DW ix Int, Manifest U ix Int) => + Proxy ix -> Fun Int Int -> Border Int -> ArrP U ix Int -> Bool +prop_MapSingletonStencilWithStride _ f b (ArrP arr) = + computeWithStride oneStride (mapStencil b (singletonStencil (apply f)) arr) == + computeAs U (A.map (apply f) arr) + -- Tests out of bounds stencil indexing prop_DangerousStencil :: Index ix => Proxy ix -> NonZero Int -> DimIx ix -> SzIx ix -> Property @@ -54,6 +58,12 @@ it "Ix2" $ property $ prop_MapSingletonStencil (Proxy :: Proxy Ix2) it "Ix3" $ property $ prop_MapSingletonStencil (Proxy :: Proxy Ix3) it "Ix4" $ property $ prop_MapSingletonStencil (Proxy :: Proxy Ix4) + it "Ix2T" $ property $ prop_MapSingletonStencil (Proxy :: Proxy Ix2T) + it "Ix3T" $ property $ prop_MapSingletonStencil (Proxy :: Proxy Ix3T) + describe "MapSingletonStencilWithStride" $ do + it "Ix1" $ property $ prop_MapSingletonStencilWithStride (Proxy :: Proxy Ix1) + it "Ix2" $ property $ prop_MapSingletonStencilWithStride (Proxy :: Proxy Ix2) + it "Ix3" $ property $ prop_MapSingletonStencilWithStride (Proxy :: Proxy Ix3) describe "DangerousStencil" $ do it "Ix1" $ property $ prop_DangerousStencil (Proxy :: Proxy Ix1) it "Ix2" $ property $ prop_DangerousStencil (Proxy :: Proxy Ix2) @@ -70,7 +80,7 @@ stencilCorners ixC ix = computeAs U . mapStencil (Fill def) (makeStencil (3 :. 3) ixC $ \f -> f ix) spec :: Spec -spec = do +spec = describe "Stencil" $ do stencilSpec let arr = [[1, 2, 3], [4, 5, 6], [7, 8, 9]] :: Array U Ix2 Int @@ -91,37 +101,14 @@ stencilCorners (2 :. 2) (-2 :. -2) arr `shouldBe` [[0, 0, 0], [0, 0, 0], [0, 0, 1]] it "Direction Left/Bottom Corner" $ stencilCorners (2 :. 0) (-2 :. 2) arr `shouldBe` [[0, 0, 0], [0, 0, 0], [3, 0, 0]] - describe "reformDW" $ do + describe "mapStencil with stride" $ do + let kernel = [[-1, 0, 1], [0, 1, 0], [-1, 0, 1]] :: Array U Ix2 Int + stencil = makeConvolutionStencilFromKernel kernel + stride = Stride 2 it "map stencil with stride on small array" $ - let kernel = [[-1, 0, 1], [0, 1, 0], [-1, 0, 1]] :: Array U Ix2 Int - stencil = makeConvolutionStencilFromKernel kernel - stride = 2 - strideArr = mapStride stride (1 :. 1) $ mapStencil (Fill 0) stencil arr - in computeAs U strideArr `shouldBe` [[-4]] + let strideArr = mapStencil (Fill 0) stencil arr + in computeWithStrideAs U stride strideArr `shouldBe` [[-4, 8],[2, 14]] it "map stencil with stride on larger array" $ - let kernel = [[-1, 0, 1], [0, 1, 0], [-1, 0, 1]] :: Array U Ix2 Int - stencil = makeConvolutionStencilFromKernel kernel - stride = 2 - largeArr = makeArrayR U Seq (5 :. 5) (succ . toLinearIndex (5 :. 5)) - stencilledArr = mapStencil (Fill 0) stencil largeArr - strideArr = mapStride stride (2 :. 2) stencilledArr - in do computeAs U strideArr `shouldBe` [[-6, 1], [-13, 9]] - it "resize DWArray resulting from mapStencil" $ - let kernel = [[-1, 0, 1], [0, 1, 0], [-1, 0, 1]] :: Array U Ix2 Int - stencil = makeConvolutionStencilFromKernel kernel - result = unsafeBackpermuteDW (+1) (subtract 1) (5 :. 5) $ mapStencil (Fill 0) stencil arr - expectation = - [ [ -1, -2, -2, 2, 3] - , [ -4, -4, 0, 8, 6] - , [ -8, -6, 1, 16, 12] - , [ -4, 2, 6, 14, 6] - , [ -7, -8, -2, 8, 9] - ] - in computeAs U result `shouldBe` expectation - -mapStride :: Index ix => Int -> ix -> Array DW ix e -> Array DW ix e -mapStride stride sz = - let toOldIndex = liftIndex (* stride) - ceilingDivStride a = ceiling $ (fromIntegral a :: Double) / fromIntegral stride - toNewIndex = liftIndex ceilingDivStride - in unsafeBackpermuteDW toNewIndex toOldIndex sz + let largeArr = makeArrayR U Seq (5 :. 5) (succ . toLinearIndex (5 :. 5)) + strideArr = mapStencil (Fill 0) stencil largeArr + in computeWithStrideAs U stride strideArr `shouldBe` [[-6, 1, 14], [-13, 9, 43], [4, 21, 44]] diff --git a/tests/Data/Massiv/Core/IndexSpec.hs b/tests/Data/Massiv/Core/IndexSpec.hs --- a/tests/Data/Massiv/Core/IndexSpec.hs +++ b/tests/Data/Massiv/Core/IndexSpec.hs @@ -36,8 +36,16 @@ else return $ Sz sz instance (Index ix, Arbitrary ix) => Arbitrary (SzZ ix) where - arbitrary = SzZ <$> liftIndex abs <$> arbitrary + arbitrary = do + sz <- liftIndex abs <$> arbitrary + if totalElem sz > 200000 + then arbitrary + else return $ SzZ sz +instance (Index ix, Arbitrary ix) => Arbitrary (Stride ix) where + arbitrary = do + Positive (Small x) <- arbitrary + Stride <$> liftIndex ((+1) . (`mod` x)) <$> arbitrary instance (Index ix, Arbitrary ix) => Arbitrary (SzIx ix) where arbitrary = do @@ -85,6 +93,20 @@ instance CoArbitrary Ix5 where coarbitrary (i :> ix) = coarbitrary i . coarbitrary ix + + +-- instance Arbitrary Ix2 where +-- arbitrary = (:.) <$> arbitrary <*> arbitrary + +-- instance (Arbitrary (Ix (n - 1))) => Arbitrary (IxN n) where +-- arbitrary = (:>) <$> arbitrary <*> arbitrary + +-- instance CoArbitrary Ix2 where +-- coarbitrary (i :. j) = coarbitrary i . coarbitrary j + +-- instance CoArbitrary (Ix (n - 1)) => CoArbitrary (IxN n) where +-- coarbitrary (i :> ix) = coarbitrary i . coarbitrary ix + prop_IsSafeIx :: Index ix => proxy ix -> SzIx ix -> Bool diff --git a/tests/Data/Massiv/CoreArbitrary.hs b/tests/Data/Massiv/CoreArbitrary.hs --- a/tests/Data/Massiv/CoreArbitrary.hs +++ b/tests/Data/Massiv/CoreArbitrary.hs @@ -31,8 +31,10 @@ import Test.QuickCheck import Test.QuickCheck.Monadic +-- | Arbitrary non-empty array. Computation strategy can be either `Seq` or `Par`. newtype Arr r ix e = Arr {unArr :: Array r ix e} +-- | Arbitrary small and possibly empty array. Computation strategy can be either `Seq` or `Par`. newtype ArrTiny r ix e = ArrTiny {unArrTiny :: Array r ix e} -- | Tiny but non-empty @@ -42,10 +44,13 @@ newtype ArrP r ix e = ArrP {unArrP :: Array r ix e} +-- | Arbitrary non-empty array with a valid index. Can be either `Seq` or `Par` data ArrIx r ix e = ArrIx (Array r ix e) ix +-- | Arbitrary non-empty array with a valid index and `Seq` computation strategy data ArrIxS r ix e = ArrIxS (Array r ix e) ix +-- | Arbitrary non-empty array with a valid index and `Par` computation strategy data ArrIxP r ix e = ArrIxP (Array r ix e) ix deriving instance (Show (Array r ix e)) => Show (Arr r ix e) @@ -71,7 +76,6 @@ return $ makeArray comp sz func --- | Arbitrary small and possibly empty array. Computation strategy can be either `Seq` or `Par`. instance (CoArbitrary ix, Arbitrary ix, Typeable e, Construct r ix e, Arbitrary e) => Arbitrary (ArrTiny r ix e) where arbitrary = do @@ -89,7 +93,6 @@ comp <- oneof [pure Seq, pure Par] return $ ArrTiny1 $ makeArray comp (liftIndex (succ . (`mod` 10)) sz) func --- | Arbitrary non-empty array. Computation strategy can be either `Seq` or `Par`. instance (CoArbitrary ix, Arbitrary ix, Typeable e, Construct r ix e, Arbitrary e) => Arbitrary (Arr r ix e) where arbitrary = do @@ -113,7 +116,6 @@ Arr arr <- arbitrary return $ ArrP (setComp Par arr) --- | Arbitrary non-empty array with a valid index instance (CoArbitrary ix, Arbitrary ix, Typeable e, Construct r ix e, Arbitrary e) => Arbitrary (ArrIx r ix e) where arbitrary = do @@ -122,7 +124,6 @@ comp <- arbitrary return $ ArrIx (makeArray comp sz func) ix --- | Arbitrary non-empty array with a valid index instance (CoArbitrary ix, Arbitrary ix, Typeable e, Construct r ix e, Arbitrary e) => Arbitrary (ArrIxS r ix e) where arbitrary = do diff --git a/tests/Spec.hs b/tests/Spec.hs --- a/tests/Spec.hs +++ b/tests/Spec.hs @@ -1,17 +1,19 @@ module Main where -import Data.Massiv.Array.DelayedSpec as Delayed -import Data.Massiv.Array.Manifest.VectorSpec as Vector +import Data.Massiv.Array.Delayed.WindowedSpec as Windowed +import Data.Massiv.Array.DelayedSpec as Delayed +import Data.Massiv.Array.Manifest.VectorSpec as Vector +import Data.Massiv.Array.ManifestSpec as Manifest --import Data.Massiv.Array.MutableSpec as Mutable -import Data.Massiv.Array.Ops.ConstructSpec as Construct -import Data.Massiv.Array.Ops.FoldSpec as Fold -import Data.Massiv.Array.Ops.SliceSpec as Slice -import Data.Massiv.Array.Ops.TransformSpec as Transform -import Data.Massiv.Array.StencilSpec as Stencil -import Data.Massiv.Core.IndexSpec as Index -import Data.Massiv.Core.SchedulerSpec as Scheduler -import System.IO (BufferMode (LineBuffering), - hSetBuffering, stdout) +import Data.Massiv.Array.Ops.ConstructSpec as Construct +import Data.Massiv.Array.Ops.FoldSpec as Fold +import Data.Massiv.Array.Ops.SliceSpec as Slice +import Data.Massiv.Array.Ops.TransformSpec as Transform +import Data.Massiv.Array.StencilSpec as Stencil +import Data.Massiv.Core.IndexSpec as Index +import Data.Massiv.Core.SchedulerSpec as Scheduler +import System.IO (BufferMode (LineBuffering), + hSetBuffering, stdout) import Test.Hspec @@ -29,6 +31,8 @@ Slice.spec Transform.spec describe "Delayed" $ Delayed.spec + describe "Windowed" $ Windowed.spec + describe "Manifest" $ Manifest.spec --describe "Mutable" $ Mutable.spec describe "Stencil" $ Stencil.spec describe "Vector" $ Vector.spec