{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Data.Massiv.Array.Mutable
(
msize
, read
, read'
, write
, write'
, modify
, modify'
, swap
, swap'
, new
, thaw
, thawS
, freeze
, freezeS
, makeMArray
, makeMArrayLinear
, makeMArrayS
, makeMArrayLinearS
, createArray_
, createArray
, createArrayS_
, createArrayS
, createArrayST_
, createArrayST
, generateArray
, generateArrayLinear
, generateArrayS
, generateArrayLinearS
, unfoldrPrimM_
, iunfoldrPrimM_
, unfoldrPrimM
, iunfoldrPrimM
, unfoldlPrimM_
, iunfoldlPrimM_
, unfoldlPrimM
, iunfoldlPrimM
, forPrimM_
, iforPrimM_
, iforLinearPrimM_
, withMArray
, withMArrayS
, withMArrayST
, initialize
, initializeNew
, Mutable
, MArray
, RealWorld
, computeInto
, loadArray
, loadArrayS
) where
import Control.Monad (unless)
import Control.Monad.ST
import Control.Scheduler
import Data.Massiv.Core.Common
import Prelude hiding (mapM, read)
new ::
forall r ix e m. (Mutable r ix e, PrimMonad m)
=> Sz ix
-> m (MArray (PrimState m) r ix e)
new = initializeNew Nothing
{-# INLINE new #-}
thaw :: forall r ix e m. (Mutable r ix e, MonadIO m) => Array r ix e -> m (MArray RealWorld r ix e)
thaw arr = liftIO $ makeMArrayLinear (getComp arr) (size arr) (pure . unsafeLinearIndexM arr)
{-# INLINE thaw #-}
thawS ::
forall r ix e m. (Mutable r ix e, PrimMonad m)
=> Array r ix e
-> m (MArray (PrimState m) r ix e)
thawS arr = makeMArrayLinearS (size arr) (pure . unsafeLinearIndexM arr)
{-# INLINE thawS #-}
freeze ::
forall r ix e m. (Mutable r ix e, MonadIO m)
=> Comp
-> MArray RealWorld r ix e
-> m (Array r ix e)
freeze comp marr = liftIO $ generateArrayLinear comp (msize marr) (unsafeLinearRead marr)
{-# INLINE freeze #-}
freezeS ::
forall r ix e m. (Mutable r ix e, PrimMonad m)
=> MArray (PrimState m) r ix e
-> m (Array r ix e)
freezeS marr = generateArrayLinearS Seq (msize marr) (unsafeLinearRead marr)
{-# INLINE freezeS #-}
newMaybeInitialized ::
(Load r' ix e, Mutable r ix e, PrimMonad m) => Array r' ix e -> m (MArray (PrimState m) r ix e)
newMaybeInitialized !arr = do
let !sz = size arr
marr <- unsafeNew sz
mapM_ (unsafeLinearSet marr 0 (totalElem sz)) $ defaultElement arr
pure marr
{-# INLINE newMaybeInitialized #-}
loadArrayS ::
forall r ix e r' m. (Load r' ix e, Mutable r ix e, PrimMonad m)
=> Array r' ix e
-> m (MArray (PrimState m) r ix e)
loadArrayS arr = do
marr <- newMaybeInitialized arr
loadArrayM trivialScheduler_ arr (unsafeLinearWrite marr)
pure marr
{-# INLINE loadArrayS #-}
loadArray ::
forall r ix e r' m. (Load r' ix e, Mutable r ix e, MonadIO m)
=> Array r' ix e
-> m (MArray RealWorld r ix e)
loadArray arr =
liftIO $ do
marr <- newMaybeInitialized arr
withScheduler_ (getComp arr) $ \scheduler -> loadArrayM scheduler arr (unsafeLinearWrite marr)
pure marr
{-# INLINE loadArray #-}
computeInto ::
(Load r' ix' e, Mutable r ix e, MonadIO m)
=> MArray RealWorld r ix e
-> Array r' ix' e
-> m ()
computeInto !mArr !arr =
liftIO $ do
unless (totalElem (msize mArr) == totalElem (size arr)) $
throwM $ SizeElementsMismatchException (msize mArr) (size arr)
withScheduler_ (getComp arr) $ \scheduler -> loadArrayM scheduler arr (unsafeLinearWrite mArr)
{-# INLINE computeInto #-}
makeMArrayS ::
forall r ix e m. (Mutable r ix e, PrimMonad m)
=> Sz ix
-> (ix -> m e)
-> m (MArray (PrimState m) r ix e)
makeMArrayS sz f = makeMArrayLinearS sz (f . fromLinearIndex sz)
{-# INLINE makeMArrayS #-}
makeMArrayLinearS ::
forall r ix e m. (Mutable r ix e, PrimMonad m)
=> Sz ix
-> (Int -> m e)
-> m (MArray (PrimState m) r ix e)
makeMArrayLinearS sz f = do
marr <- unsafeNew sz
loopM_ 0 (< totalElem (msize marr)) (+ 1) (\ !i -> f i >>= unsafeLinearWrite marr i)
return marr
{-# INLINE makeMArrayLinearS #-}
makeMArray ::
forall r ix e m. (PrimMonad m, MonadUnliftIO m, Mutable r ix e)
=> Comp
-> Sz ix
-> (ix -> m e)
-> m (MArray (PrimState m) r ix e)
makeMArray comp sz f = makeMArrayLinear comp sz (f . fromLinearIndex sz)
{-# INLINE makeMArray #-}
makeMArrayLinear ::
forall r ix e m. (PrimMonad m, MonadUnliftIO m, Mutable r ix e)
=> Comp
-> Sz ix
-> (Int -> m e)
-> m (MArray (PrimState m) r ix e)
makeMArrayLinear comp sz f = do
marr <- unsafeNew sz
withScheduler_ comp $ \scheduler ->
splitLinearlyWithM_ scheduler (totalElem sz) f (unsafeLinearWrite marr)
return marr
{-# INLINE makeMArrayLinear #-}
createArray_ ::
forall r ix e a m. (Mutable r ix e, PrimMonad m, MonadUnliftIO m)
=> Comp
-> Sz ix
-> (Scheduler m () -> MArray (PrimState m) r ix e -> m a)
-> m (Array r ix e)
createArray_ comp sz action = do
marr <- new sz
withScheduler_ comp (`action` marr)
unsafeFreeze comp marr
{-# INLINE createArray_ #-}
createArray ::
forall r ix e a m. (Mutable r ix e, PrimMonad m, MonadUnliftIO m)
=> Comp
-> Sz ix
-> (Scheduler m a -> MArray (PrimState m) r ix e -> m [a])
-> m ([a], Array r ix e)
createArray comp sz action = do
marr <- new sz
a <- withScheduler comp (`action` marr)
arr <- unsafeFreeze comp marr
return (a, arr)
{-# INLINE createArray #-}
createArrayS_ ::
forall r ix e a m. (Mutable r ix e, PrimMonad m)
=> Comp
-> Sz ix
-> (MArray (PrimState m) r ix e -> m a)
-> m (Array r ix e)
createArrayS_ comp sz action = snd <$> createArrayS comp sz action
{-# INLINE createArrayS_ #-}
createArrayS ::
forall r ix e a m. (Mutable r ix e, PrimMonad m)
=> Comp
-> Sz ix
-> (MArray (PrimState m) r ix e -> m a)
-> m (a, Array r ix e)
createArrayS comp sz action = do
marr <- new sz
a <- action marr
arr <- unsafeFreeze comp marr
return (a, arr)
{-# INLINE createArrayS #-}
createArrayST_ ::
forall r ix e a. Mutable r ix e
=> Comp
-> Sz ix
-> (forall s. MArray s r ix e -> ST s a)
-> Array r ix e
createArrayST_ comp sz action = runST $ createArrayS_ comp sz action
{-# INLINE createArrayST_ #-}
createArrayST ::
forall r ix e a. Mutable r ix e
=> Comp
-> Sz ix
-> (forall s. MArray s r ix e -> ST s a)
-> (a, Array r ix e)
createArrayST comp sz action = runST $ createArrayS comp sz action
{-# INLINE createArrayST #-}
generateArrayS ::
forall r ix e m. (Mutable r ix e, PrimMonad m)
=> Comp
-> Sz ix
-> (ix -> m e)
-> m (Array r ix e)
generateArrayS comp sz gen = generateArrayLinearS comp sz (gen . fromLinearIndex sz)
{-# INLINE generateArrayS #-}
generateArrayLinearS ::
forall r ix e m. (Mutable r ix e, PrimMonad m)
=> Comp
-> Sz ix
-> (Int -> m e)
-> m (Array r ix e)
generateArrayLinearS comp sz gen = do
marr <- unsafeNew sz
loopM_ 0 (< totalElem (msize marr)) (+ 1) $ \i -> gen i >>= unsafeLinearWrite marr i
unsafeFreeze comp marr
{-# INLINE generateArrayLinearS #-}
generateArray ::
forall r ix e m. (MonadUnliftIO m, PrimMonad m, Mutable r ix e)
=> Comp
-> Sz ix
-> (ix -> m e)
-> m (Array r ix e)
generateArray comp sz f = generateArrayLinear comp sz (f . fromLinearIndex sz)
{-# INLINE generateArray #-}
generateArrayLinear ::
forall r ix e m. (MonadUnliftIO m, PrimMonad m, Mutable r ix e)
=> Comp
-> Sz ix
-> (Int -> m e)
-> m (Array r ix e)
generateArrayLinear comp sz f = makeMArrayLinear comp sz f >>= unsafeFreeze comp
{-# INLINE generateArrayLinear #-}
unfoldrPrimM_ ::
forall r ix e a m. (Mutable r ix e, PrimMonad m)
=> Comp
-> Sz ix
-> (a -> m (e, a))
-> a
-> m (Array r ix e)
unfoldrPrimM_ comp sz gen acc0 = snd <$> unfoldrPrimM comp sz gen acc0
{-# INLINE unfoldrPrimM_ #-}
iunfoldrPrimM_ ::
forall r ix e a m. (Mutable r ix e, PrimMonad m)
=> Comp
-> Sz ix
-> (a -> ix -> m (e, a))
-> a
-> m (Array r ix e)
iunfoldrPrimM_ comp sz gen acc0 = snd <$> iunfoldrPrimM comp sz gen acc0
{-# INLINE iunfoldrPrimM_ #-}
iunfoldrPrimM ::
forall r ix e a m. (Mutable r ix e, PrimMonad m)
=> Comp
-> Sz ix
-> (a -> ix -> m (e, a))
-> a
-> m (a, Array r ix e)
iunfoldrPrimM comp sz gen acc0 =
createArrayS comp sz $ \marr ->
let sz' = msize marr
in iterLinearM sz' 0 (totalElem sz') 1 (<) acc0 $ \i ix acc -> do
(e, acc') <- gen acc ix
unsafeLinearWrite marr i e
return acc'
{-# INLINE iunfoldrPrimM #-}
unfoldrPrimM ::
forall r ix e a m. (Mutable r ix e, PrimMonad m)
=> Comp
-> Sz ix
-> (a -> m (e, a))
-> a
-> m (a, Array r ix e)
unfoldrPrimM comp sz gen acc0 =
createArrayS comp sz $ \marr ->
let sz' = msize marr
in loopM 0 (< totalElem sz') (+1) acc0 $ \i acc -> do
(e, acc') <- gen acc
unsafeLinearWrite marr i e
return acc'
{-# INLINE unfoldrPrimM #-}
unfoldlPrimM_ ::
forall r ix e a m. (Mutable r ix e, PrimMonad m)
=> Comp
-> Sz ix
-> (a -> m (a, e))
-> a
-> m (Array r ix e)
unfoldlPrimM_ comp sz gen acc0 = snd <$> unfoldlPrimM comp sz gen acc0
{-# INLINE unfoldlPrimM_ #-}
iunfoldlPrimM_ ::
forall r ix e a m. (Mutable r ix e, PrimMonad m)
=> Comp
-> Sz ix
-> (a -> ix -> m (a, e))
-> a
-> m (Array r ix e)
iunfoldlPrimM_ comp sz gen acc0 = snd <$> iunfoldlPrimM comp sz gen acc0
{-# INLINE iunfoldlPrimM_ #-}
iunfoldlPrimM ::
forall r ix e a m. (Mutable r ix e, PrimMonad m)
=> Comp
-> Sz ix
-> (a -> ix -> m (a, e))
-> a
-> m (a, Array r ix e)
iunfoldlPrimM comp sz gen acc0 =
createArrayS comp sz $ \marr ->
let sz' = msize marr
in iterLinearM sz' (totalElem sz' - 1) 0 (negate 1) (>=) acc0 $ \i ix acc -> do
(acc', e) <- gen acc ix
unsafeLinearWrite marr i e
return acc'
{-# INLINE iunfoldlPrimM #-}
unfoldlPrimM ::
forall r ix e a m. (Mutable r ix e, PrimMonad m)
=> Comp
-> Sz ix
-> (a -> m (a, e))
-> a
-> m (a, Array r ix e)
unfoldlPrimM comp sz gen acc0 =
createArrayS comp sz $ \marr ->
let sz' = msize marr
in loopDeepM 0 (< totalElem sz') (+1) acc0 $ \i acc -> do
(acc', e) <- gen acc
unsafeLinearWrite marr i e
return acc'
{-# INLINE unfoldlPrimM #-}
forPrimM_ :: (Mutable r ix e, PrimMonad m) => MArray (PrimState m) r ix e -> (e -> m e) -> m ()
forPrimM_ marr f =
loopM_ 0 (< totalElem (msize marr)) (+1) (unsafeLinearModify marr (const f))
{-# INLINE forPrimM_ #-}
iforPrimM_ ::
(Mutable r ix e, PrimMonad m) => MArray (PrimState m) r ix e -> (ix -> e -> m e) -> m ()
iforPrimM_ marr f = iforLinearPrimM_ marr (f . fromLinearIndex (msize marr))
{-# INLINE iforPrimM_ #-}
iforLinearPrimM_ ::
(Mutable r ix e, PrimMonad m) => MArray (PrimState m) r ix e -> (Int -> e -> m e) -> m ()
iforLinearPrimM_ marr f = loopM_ 0 (< totalElem (msize marr)) (+ 1) (unsafeLinearModify marr f)
{-# INLINE iforLinearPrimM_ #-}
withMArray ::
(Mutable r ix e, MonadUnliftIO m)
=> Array r ix e
-> (Int -> (m () -> m ()) -> MArray RealWorld r ix e -> m a)
-> m (Array r ix e)
withMArray arr action = do
marr <- thaw arr
withScheduler_ (getComp arr) $ \scheduler ->
action (numWorkers scheduler) (scheduleWork scheduler) marr
liftIO $ unsafeFreeze (getComp arr) marr
{-# INLINE withMArray #-}
withMArrayS ::
(Mutable r ix e, PrimMonad m)
=> Array r ix e
-> (MArray (PrimState m) r ix e -> m a)
-> m (Array r ix e)
withMArrayS arr action = do
marr <- thawS arr
_ <- action marr
unsafeFreeze (getComp arr) marr
{-# INLINE withMArrayS #-}
withMArrayST ::
Mutable r ix e
=> Array r ix e
-> (forall s . MArray s r ix e -> ST s a)
-> Array r ix e
withMArrayST arr f = runST $ withMArrayS arr f
{-# INLINE withMArrayST #-}
read :: (Mutable r ix e, PrimMonad m) =>
MArray (PrimState m) r ix e -> ix -> m (Maybe e)
read marr ix =
if isSafeIndex (msize marr) ix
then Just <$> unsafeRead marr ix
else return Nothing
{-# INLINE read #-}
read' :: (Mutable r ix e, PrimMonad m) => MArray (PrimState m) r ix e -> ix -> m e
read' marr ix =
read marr ix >>= \case
Just e -> pure e
Nothing -> throw $ IndexOutOfBoundsException (msize marr) ix
{-# INLINE read' #-}
write :: (Mutable r ix e, PrimMonad m) => MArray (PrimState m) r ix e -> ix -> e -> m Bool
write marr ix e =
if isSafeIndex (msize marr) ix
then unsafeWrite marr ix e >> pure True
else pure False
{-# INLINE write #-}
write' ::
(Mutable r ix e, PrimMonad m) => MArray (PrimState m) r ix e -> ix -> e -> m ()
write' marr ix e = write marr ix e >>= (`unless` throw (IndexOutOfBoundsException (msize marr) ix))
{-# INLINE write' #-}
modify :: (Mutable r ix e, PrimMonad m) => MArray (PrimState m) r ix e -> (e -> e) -> ix -> m Bool
modify marr f ix =
if isSafeIndex (msize marr) ix
then do
val <- unsafeRead marr ix
unsafeWrite marr ix $ f val
return True
else return False
{-# INLINE modify #-}
modify' :: (Mutable r ix e, PrimMonad m) =>
MArray (PrimState m) r ix e -> (e -> e) -> ix -> m ()
modify' marr f ix =
modify marr f ix >>= (`unless` throw (IndexOutOfBoundsException (msize marr) ix))
{-# INLINE modify' #-}
swap :: (Mutable r ix e, PrimMonad m) => MArray (PrimState m) r ix e -> ix -> ix -> m Bool
swap marr ix1 ix2 = do
let sz = msize marr
if isSafeIndex sz ix1 && isSafeIndex sz ix2
then do
val <- unsafeRead marr ix1
unsafeRead marr ix2 >>= unsafeWrite marr ix1
unsafeWrite marr ix2 val
return True
else return False
{-# INLINE swap #-}
swap' ::
(Mutable r ix e, PrimMonad m) => MArray (PrimState m) r ix e -> ix -> ix -> m ()
swap' marr ix1 ix2 =
swap marr ix1 ix2 >>=
(`unless` if isSafeIndex (msize marr) ix1
then throw $ IndexOutOfBoundsException (msize marr) ix2
else throw $ IndexOutOfBoundsException (msize marr) ix1)
{-# INLINE swap' #-}