module Data.Yarr.Repr.Delayed (
D,
DT,
UArray(..),
L, SH, fromFunction, fromLinearFunction,
delay, delayShaped, delayLinear,
linearConst, shapedConst,
) where
import Prelude as P
import Control.Monad
import Data.Yarr.Base
import Data.Yarr.Fusion as F
import Data.Yarr.Eval
import Data.Yarr.Shape
import Data.Yarr.Utils.FixedVector as V
data D
instance Shape sh => Regular D L sh a where
data UArray D L sh a =
LinearDelayed
!sh
(IO ())
(IO ())
(Int -> IO a)
extent (LinearDelayed sh _ _ _) = sh
touchArray (LinearDelayed _ tch _ _) = tch
force (LinearDelayed sh _ iforce _) =
(sh `deepseq` return ()) >> iforce
instance Shape sh => NFData (UArray D L sh a) where
rnf (LinearDelayed sh tch iforce lget) =
sh `deepseq` tch `seq` iforce `seq` lget `seq` ()
instance Shape sh => USource D L sh a where
linearIndex (LinearDelayed _ _ _ lget) = lget
instance (Shape sh, Vector v e) => VecRegular D D L sh v e where
slices (LinearDelayed sh tch iforce lget) =
V.generate
(\i -> LinearDelayed sh tch iforce ((return . (V.! i)) <=< lget))
instance (Shape sh, Vector v e) => UVecSource D D L sh v e
instance Fusion r D L sh where
fmapM f arr =
LinearDelayed
(extent arr) (touchArray arr) (force arr) (f <=< linearIndex arr)
fzip2M f arr1 arr2 =
let sh = intersect (vl_2 (extent arr1) (extent arr2))
tch = touchArray arr1 >> touchArray arr2
iforce = force arr1 >> force arr2
lget i = do
v1 <- linearIndex arr1 i
v2 <- linearIndex arr2 i
f v1 v2
in LinearDelayed sh tch iforce lget
fzip3M f arr1 arr2 arr3 =
let sh = intersect (vl_3 (extent arr1) (extent arr2) (extent arr3))
tch = touchArray arr1 >> touchArray arr2 >> touchArray arr3
iforce = force arr1 >> force arr2 >> force arr3
lget i = do
v1 <- linearIndex arr1 i
v2 <- linearIndex arr2 i
v3 <- linearIndex arr3 i
f v1 v2 v3
in LinearDelayed sh tch iforce lget
fzipM fun arrs =
let shapes = V.map extent arrs
sh = V.head shapes
tch = V.mapM_ touchArray arrs
iforce = V.mapM_ force arrs
lgets = V.map linearIndex arrs
lget i = do
v <- V.mapM ($ i) lgets
inspect v fun
in if V.all (== sh) shapes
then LinearDelayed sh tch iforce lget
else error ("Yarr! All arrays in linear zip " ++
"must be of the same extent")
instance DefaultFusion D D L sh
instance Shape sh => Regular D SH sh a where
data UArray D SH sh a =
ShapeDelayed
!sh
(IO ())
(IO ())
(sh -> IO a)
extent (ShapeDelayed sh _ _ _) = sh
touchArray (ShapeDelayed _ tch _ _) = tch
force (ShapeDelayed sh _ iforce _) = (sh `deepseq` return ()) >> iforce
instance Shape sh => NFData (UArray D SH sh a) where
rnf (ShapeDelayed sh tch iforce get) =
sh `deepseq` tch `seq` iforce `seq` get `seq` ()
instance Shape sh => USource D SH sh a where
index (ShapeDelayed _ _ _ get) = get
instance (Shape sh, Vector v e) => VecRegular D D SH sh v e where
slices (ShapeDelayed sh tch iforce get) =
V.generate
(\i -> ShapeDelayed sh tch iforce ((return . (V.! i)) <=< get))
instance (Shape sh, Vector v e) => UVecSource D D SH sh v e
instance Shape sh => IFusion r l D SH sh where
fimapM f arr =
ShapeDelayed
(extent arr) (touchArray arr) (force arr)
(\sh -> index arr sh >>= f sh)
fizip2M f arr1 arr2 =
let sh = intersect (vl_2 (extent arr1) (extent arr2))
tch = touchArray arr1 >> touchArray arr2
iforce = force arr1 >> force arr2
get sh = do
v1 <- index arr1 sh
v2 <- index arr2 sh
f sh v1 v2
in ShapeDelayed sh tch iforce get
fizip3M f arr1 arr2 arr3 =
let sh = intersect (vl_3 (extent arr1) (extent arr2) (extent arr3))
tch = touchArray arr1 >> touchArray arr2 >> touchArray arr3
iforce = force arr1 >> force arr2 >> force arr3
get sh = do
v1 <- index arr1 sh
v2 <- index arr2 sh
v3 <- index arr3 sh
f sh v1 v2 v3
in ShapeDelayed sh tch iforce get
fizipM ifun arrs =
let shapes = V.map extent arrs
sh = intersect shapes
tch = V.mapM_ touchArray arrs
iforce = V.mapM_ force arrs
gets = V.map index arrs
get sh = do
v <- V.mapM ($ sh) gets
inspect v (ifun sh)
in ShapeDelayed sh tch iforce get
instance Shape sh => DefaultIFusion D L D SH sh
instance Shape sh => DefaultIFusion D SH D SH sh
instance Shape sh => DefaultFusion D D SH sh
delay :: (USource r l sh a, USource D l sh a, Fusion r D l sh)
=> UArray r l sh a -> UArray D l sh a
delay = F.fmap id
fromFunction
:: Shape sh
=> sh
-> (sh -> IO a)
-> UArray D SH sh a
fromFunction sh f = ShapeDelayed sh (return ()) (return ()) f
fromLinearFunction
:: Shape sh
=> sh
-> (Int -> IO a)
-> UArray D L sh a
fromLinearFunction sh f = LinearDelayed sh (return ()) (return ()) f
linearConst
:: Shape sh => sh -> a -> UArray D L sh a
linearConst sh x = fromLinearFunction sh (const (return x))
shapedConst
:: Shape sh => sh -> a -> UArray D SH sh a
shapedConst sh x = fromFunction sh (const (return x))
delayShaped :: USource r l sh a => UArray r l sh a -> UArray D SH sh a
delayShaped arr =
ShapeDelayed (extent arr) (touchArray arr) (force arr) (index arr)
delayLinear :: USource r l sh a => UArray r l sh a -> UArray D L sh a
delayLinear arr =
LinearDelayed (extent arr) (touchArray arr) (force arr) (linearIndex arr)
data DT
instance Shape sh => Regular DT SH sh a where
data UArray DT SH sh a =
ShapeDelayedTarget
!sh
(IO ())
(IO ())
(sh -> a -> IO ())
extent (ShapeDelayedTarget sh _ _ _) = sh
touchArray (ShapeDelayedTarget _ tch _ _) = tch
force (ShapeDelayedTarget sh _ iforce _) =
(sh `deepseq` return ()) >> iforce
instance Shape sh => NFData (UArray DT SH sh a) where
rnf (ShapeDelayedTarget sh tch iforce wr) =
sh `deepseq` tch `seq` iforce `seq` wr `seq` ()
instance Shape sh => UTarget DT SH sh a where
write (ShapeDelayedTarget _ _ _ wr) = wr