@@ -25,7 +25,8 @@
2525import Control.DeepSeq (NFData(..))
2626import Control.Monad (when)
2727import Control.Monad.IO.Class (MonadIO(..))
28−import Control.Monad.State.Strict (StateT, get, put)
28+import Control.Monad.State.Strict (StateT, get, put, MonadState)
29+import qualified Control.Monad.State.Strict as State
2930import Data.Functor.Identity (Identity, runIdentity)
3031import Data.IORef (newIORef, modifyIORef')
3132import GHC.Generics (Generic)
@@ -824,7 +825,6 @@ o_1_space_mapping value =
824825
825826 -- Mapping
826827 , benchIOSink value "map" (mapN serially 1)
827− , benchIOSink value "fmap" (fmapN serially 1)
828828 , bench "sequence" $ nfIO $ randomRIO (1, 1000) >>= \n ->
829829 sequence serially (sourceUnfoldrAction value n)
830830 , benchIOSink value "mapM" (mapM serially 1)
@@ -844,7 +844,6 @@ o_1_space_mappingX4 :: Int -> [Benchmark]
844844o_1_space_mappingX4 value =
845845 [ bgroup "mappingX4"
846846 [ benchIOSink value "map" (mapN serially 4)
847− , benchIOSink value "fmap" (fmapN serially 4)
848847 , benchIOSink value "mapM" (mapM serially 4)
849848
850849 , benchIOSink value "scan" (scan 4)
@@ -853,6 +852,88 @@ o_1_space_mappingX4 value =
853852 ]
854853 ]
855854
855+-------------------------------------------------------------------------------
856+-- Iteration/looping utilities
857+-------------------------------------------------------------------------------
858+
859+{-# INLINE iterateN #-}
860+iterateN :: (Int -> a -> a) -> a -> Int -> a
861+iterateN g initial count = f count initial
862+
863+ where
864+
865+ f (0 :: Int) x = x
866+ f i x = f (i - 1) (g i x)
867+
868+-- Iterate a transformation over a singleton stream
869+{-# INLINE iterateSingleton #-}
870+iterateSingleton :: S.MonadAsync m
871+ => (Int -> SerialT m Int -> SerialT m Int)
872+ -> Int
873+ -> Int
874+ -> SerialT m Int
875+iterateSingleton g count n = iterateN g (return n) count
876+
877+-- XXX need to check why this is slower than the explicit recursion above, even
878+-- if the above code is written in a foldr like head recursive way. We also
879+-- need to try this with foldlM' once #150 is fixed.
880+-- However, it is perhaps best to keep the iteration benchmarks independent of
881+-- foldrM and any related fusion issues.
882+{-# INLINE _iterateSingleton #-}
883+_iterateSingleton ::
884+ S.MonadAsync m
885+ => (Int -> SerialT m Int -> SerialT m Int)
886+ -> Int
887+ -> Int
888+ -> SerialT m Int
889+_iterateSingleton g value n = S.foldrM g (return n) $ sourceIntFromTo value n
890+
891+-- Apply transformation g count times on a stream of length len
892+{-# INLINE iterateSource #-}
893+iterateSource ::
894+ S.MonadAsync m
895+ => (SerialT m Int -> SerialT m Int)
896+ -> Int
897+ -> Int
898+ -> Int
899+ -> SerialT m Int
900+iterateSource g count len n = f count (sourceUnfoldrM len n)
901+
902+ where
903+
904+ f (0 :: Int) stream = stream
905+ f i stream = f (i - 1) (g stream)
906+
907+-------------------------------------------------------------------------------
908+-- Functor
909+-------------------------------------------------------------------------------
910+
911+o_1_space_functor :: Int -> [Benchmark]
912+o_1_space_functor value =
913+ [ bgroup "Functor"
914+ [ benchIOSink value "fmap" (fmapN serially 1)
915+ , benchIOSink value "fmap x 4" (fmapN serially 4)
916+ ]
917+ ]
918+
919+o_n_space_functor :: Int -> [Benchmark]
920+o_n_space_functor value =
921+ [ bgroup "Functor"
922+ [ benchIO "(+) (n times) (baseline)" $ \i0 ->
923+ iterateN (\i acc -> acc >>= \n -> return $ i + n) (return i0) value
924+ , benchIOSrc serially "(<$) (n times)" $
925+ iterateSingleton (<$) value
926+ , benchIOSrc serially "fmap (n times)" $
927+ iterateSingleton (P.fmap . (+)) value
928+ {-
929+ , benchIOSrc serially "_(<$) (n times)" $
930+ _iterateSingleton (<$) value
931+ , benchIOSrc serially "_fmap (n times)" $
932+ _iterateSingleton (P.fmap . (+)) value
933+ -}
934+ ]
935+ ]
936+
856937-------------------------------------------------------------------------------
857938-- Size reducing transformations (filtering)
858939-------------------------------------------------------------------------------
@@ -1202,61 +1283,41 @@ o_1_space_transformations_mixedX4 value =
12021283-- Iterating a transformation over and over again
12031284-------------------------------------------------------------------------------
12041285
1205−{-# INLINE iterStreamLen #-}
1206−iterStreamLen :: Int
1207−iterStreamLen = 10
1208−
1209−{-# INLINE maxIters #-}
1210−maxIters :: Int
1211−maxIters = 10000
1212−
1213−{-# INLINE iterateSource #-}
1214−iterateSource ::
1215− S.MonadAsync m
1216− => (SerialT m Int -> SerialT m Int)
1217− -> Int
1218− -> Int
1219− -> SerialT m Int
1220−iterateSource g i n = f i (sourceUnfoldrM iterStreamLen n)
1221− where
1222− f (0 :: Int) m = g m
1223− f x m = g (f (x P.- 1) m)
1224−
12251286-- this is quadratic
12261287{-# INLINE iterateScan #-}
1227−iterateScan :: S.MonadAsync m => Int -> SerialT m Int
1228−iterateScan = iterateSource (S.scanl' (+) 0) (maxIters `div` 10)
1288+iterateScan :: S.MonadAsync m => Int -> Int -> Int -> SerialT m Int
1289+iterateScan = iterateSource (S.scanl' (+) 0)
12291290
12301291-- this is quadratic
12311292{-# INLINE iterateScanl1 #-}
1232−iterateScanl1 :: S.MonadAsync m => Int -> SerialT m Int
1233−iterateScanl1 = iterateSource (S.scanl1' (+)) (maxIters `div` 10)
1293+iterateScanl1 :: S.MonadAsync m => Int -> Int -> Int -> SerialT m Int
1294+iterateScanl1 = iterateSource (S.scanl1' (+))
12341295
12351296{-# INLINE iterateMapM #-}
1236−iterateMapM :: S.MonadAsync m => Int -> SerialT m Int
1237−iterateMapM = iterateSource (S.mapM return) maxIters
1297+iterateMapM :: S.MonadAsync m => Int -> Int -> Int -> SerialT m Int
1298+iterateMapM = iterateSource (S.mapM return)
12381299
12391300{-# INLINE iterateFilterEven #-}
1240−iterateFilterEven :: S.MonadAsync m => Int -> SerialT m Int
1241−iterateFilterEven = iterateSource (S.filter even) maxIters
1301+iterateFilterEven :: S.MonadAsync m => Int -> Int -> Int -> SerialT m Int
1302+iterateFilterEven = iterateSource (S.filter even)
12421303
12431304{-# INLINE iterateTakeAll #-}
1244−iterateTakeAll :: S.MonadAsync m => Int -> Int -> SerialT m Int
1245−iterateTakeAll value = iterateSource (S.take (value + 1)) maxIters
1305+iterateTakeAll :: S.MonadAsync m => Int -> Int -> Int -> Int -> SerialT m Int
1306+iterateTakeAll value = iterateSource (S.take (value + 1))
12461307
12471308{-# INLINE iterateDropOne #-}
1248−iterateDropOne :: S.MonadAsync m => Int -> SerialT m Int
1249−iterateDropOne = iterateSource (S.drop 1) maxIters
1309+iterateDropOne :: S.MonadAsync m => Int -> Int -> Int -> SerialT m Int
1310+iterateDropOne = iterateSource (S.drop 1)
12501311
12511312{-# INLINE iterateDropWhileFalse #-}
1252−iterateDropWhileFalse :: S.MonadAsync m => Int -> Int -> SerialT m Int
1253−iterateDropWhileFalse value =
1254− iterateSource (S.dropWhile (> (value + 1))) maxIters
1313+iterateDropWhileFalse :: S.MonadAsync m
1314+ => Int -> Int -> Int -> Int -> SerialT m Int
1315+iterateDropWhileFalse value = iterateSource (S.dropWhile (> (value + 1)))
12551316
12561317{-# INLINE iterateDropWhileTrue #-}
1257−iterateDropWhileTrue :: S.MonadAsync m => Int -> Int -> SerialT m Int
1258−iterateDropWhileTrue value =
1259− iterateSource (S.dropWhile (<= (value + 1))) maxIters
1318+iterateDropWhileTrue :: S.MonadAsync m
1319+ => Int -> Int -> Int -> Int -> SerialT m Int
1320+iterateDropWhileTrue value = iterateSource (S.dropWhile (<= (value + 1)))
12601321
12611322{-# INLINE tail #-}
12621323tail :: Monad m => SerialT m a -> m ()
@@ -1272,23 +1333,31 @@ nullHeadTail s = do
12721333
12731334-- Head recursive operations.
12741335o_n_stack_iterated :: Int -> [Benchmark]
1275−o_n_stack_iterated value =
1336+o_n_stack_iterated value = by10 `seq` by100 `seq`
12761337 [ bgroup "iterated"
1277− [ benchIOSrc serially "mapMx10K" iterateMapM
1278− , benchIOSrc serially "scanx100" iterateScan
1279− , benchIOSrc serially "scanl1x100" iterateScanl1
1280− , benchIOSrc serially "filterEvenx10K" iterateFilterEven
1281− , benchIOSrc serially "takeAllx10K" (iterateTakeAll value)
1282− , benchIOSrc serially "dropOnex10K" iterateDropOne
1283− , benchIOSrc serially "dropWhileFalsex10K"
1284− (iterateDropWhileFalse value)
1285− , benchIOSrc serially "dropWhileTruex10K"
1286− (iterateDropWhileTrue value)
1338+ [ benchIOSrc serially "mapM (n/10 x 10)" $ iterateMapM by10 10
1339+ , benchIOSrc serially "scanl' (quadratic) (n/100 x 100)" $
1340+ iterateScan by100 100
1341+ , benchIOSrc serially "scanl1' (n/10 x 10)" $ iterateScanl1 by10 10
1342+ , benchIOSrc serially "filterEven (n/10 x 10)" $
1343+ iterateFilterEven by10 10
1344+ , benchIOSrc serially "takeAll (n/10 x 10)" $
1345+ iterateTakeAll value by10 10
1346+ , benchIOSrc serially "dropOne (n/10 x 10)" $ iterateDropOne by10 10
1347+ , benchIOSrc serially "dropWhileFalse (n/10 x 10)" $
1348+ iterateDropWhileFalse value by10 10
1349+ , benchIOSrc serially "dropWhileTrue (n/10 x 10)" $
1350+ iterateDropWhileTrue value by10 10
12871351 , benchIOSink value "tail" tail
12881352 , benchIOSink value "nullHeadTail" nullHeadTail
12891353 ]
12901354 ]
12911355
1356+ where
1357+
1358+ by10 = value `div` 10
1359+ by100 = value `div` 100
1360+
12921361-------------------------------------------------------------------------------
12931362-- Pipes
12941363-------------------------------------------------------------------------------
@@ -1546,49 +1615,17 @@ o_1_space_applicative value =
15461615 ]
15471616 ]
15481617
1549−{-# INLINE ap_ #-}
1550−ap_ :: Int -> Int -> IO ()
1551−ap_ value n =
1552− S.drain
1553− $ S.foldrM
1554− (\x xs -> pure x *> xs)
1555− (return () :: SerialT IO ())
1556− $ sourceUnfoldrMSerial value n
1557−
1558−{-# INLINE apRev_ #-}
1559−apRev_ :: Int -> Int -> IO ()
1560−apRev_ value n =
1561− S.drain
1562− $ S.foldrM
1563− (\x xs -> xs <* pure x)
1564− (return () :: SerialT IO ())
1565− $ sourceUnfoldrMSerial value n
1566−
1567−{-# INLINE liftA2 #-}
1568−liftA2 :: Int -> Int -> IO ()
1569−liftA2 value n =
1570− S.drain
1571− $ S.foldrM
1572− (\x xs -> AP.liftA2 (+) (pure x) xs)
1573− (S.yield 0 :: SerialT IO Int)
1574− $ sourceUnfoldrMSerial value n
1575−
1576−{-# INLINE ap #-}
1577−ap :: Int -> Int -> IO ()
1578−ap value n =
1579− S.drain
1580− $ S.foldrM
1581− (\x xs -> (P.fmap (+) (pure x) <*> xs))
1582− (S.yield 0 :: SerialT IO Int)
1583− $ sourceUnfoldrMSerial value n
1584−
15851618o_n_space_applicative :: Int -> [Benchmark]
15861619o_n_space_applicative value =
1587− [ bgroup "applicative"
1588− [ benchIO "(*>)" (ap_ value)
1589− , benchIO "(<*)" (apRev_ value)
1590− , benchIO "(<*>)" (ap value)
1591− , benchIO "liftA2" (liftA2 value)
1620+ [ bgroup "Applicative"
1621+ [ benchIOSrc serially "(*>) (n times)" $
1622+ iterateSingleton ((*>) . pure) value
1623+ , benchIOSrc serially "(<*) (n times)" $
1624+ iterateSingleton (\x xs -> xs <* pure x) value
1625+ , benchIOSrc serially "(<*>) (n times)" $
1626+ iterateSingleton (\x xs -> (P.fmap (+) (pure x) <*> xs)) value
1627+ , benchIOSrc serially "liftA2 (n times)" $
1628+ iterateSingleton (\x xs -> AP.liftA2 (+) (pure x) xs) value
15921629 ]
15931630 ]
15941631
@@ -1598,7 +1635,7 @@ o_n_space_applicative value =
15981635
15991636o_1_space_monad :: Int -> [Benchmark]
16001637o_1_space_monad value =
1601− [ bgroup "monad"
1638+ [ bgroup "Monad"
16021639 [ benchIO "outer product (sqrt n x sqrt n)" $ toNullM value serially
16031640 , benchIO "outer product (sqrt n x sqrt n) (filterAllOut)" $
16041641 filterAllOutM value serially
@@ -1613,30 +1650,13 @@ o_1_space_monad value =
16131650 ]
16141651 ]
16151652
1616−{-# INLINE bind_ #-}
1617−bind_ :: Int -> Int -> IO ()
1618−bind_ value n =
1619− S.drain
1620− $ S.foldrM
1621− (\x xs -> pure x >> xs)
1622− (return () :: SerialT IO ())
1623− $ sourceUnfoldrMSerial value n
1624−
1625−
1626−{-# INLINE bind #-}
1627−bind :: Int -> Int -> IO ()
1628−bind value n =
1629− S.drain
1630− $ S.foldrM
1631− (\x xs -> xs >>= \y -> return (x + y))
1632− (S.yield 0 :: SerialT IO Int)
1633− $ sourceUnfoldrMSerial value n
1634−
16351653o_n_space_monad :: Int -> [Benchmark]
16361654o_n_space_monad value =
1637− [ bgroup "monad"
1638− [ benchIO "(>>)" (bind_ value)
1639− , benchIO "(>>=)" (bind value)
1655+ [ bgroup "Monad"
1656+ [ benchIOSrc serially "(>>) (n times)" $
1657+ iterateSingleton ((>>) . pure) value
1658+ , benchIOSrc serially "(>>=) (n times)" $
1659+ iterateSingleton (\x xs -> xs >>= \y -> return (x + y)) value
16401660 , benchIO "outer product (sqrt n x sqrt n) (toList)" $
16411661 toListM value serially
16421662 , benchIO "outer product (sqrt n x sqrt n) (toListSome)" $
@@ -1678,6 +1698,54 @@ o_1_space_hoisting value =
16781698 ]
16791699 ]
16801700
1701+{-# INLINE iterateStateIO #-}
1702+iterateStateIO ::
1703+ (S.MonadAsync m)
1704+ => Int
1705+ -> StateT Int m Int
1706+iterateStateIO n = do
1707+ x <- get
1708+ if x > n
1709+ then do
1710+ put (x - 1)
1711+ iterateStateIO n
1712+ else return x
1713+
1714+{-# INLINE iterateStateT #-}
1715+iterateStateT :: Int -> SerialT (StateT Int IO) Int
1716+iterateStateT n = do
1717+ x <- get
1718+ if x > n
1719+ then do
1720+ put (x - 1)
1721+ iterateStateT n
1722+ else return x
1723+
1724+{-# INLINE iterateState #-}
1725+iterateState ::
1726+ (S.MonadAsync m, MonadState Int m)
1727+ => Int
1728+ -> SerialT m Int
1729+iterateState n = do
1730+ x <- get
1731+ if x > n
1732+ then do
1733+ put (x - 1)
1734+ iterateState n
1735+ else return x
1736+
1737+o_n_space_transformer :: Int -> [Benchmark]
1738+o_n_space_transformer value =
1739+ [ bgroup "transformer"
1740+ [ benchIO "StateT Int IO (n times) (baseline)" $ \n ->
1741+ State.evalStateT (iterateStateIO n) value
1742+ , benchIO "SerialT (StateT Int IO) (n times)" $ \n ->
1743+ State.evalStateT (S.drain (iterateStateT n)) value
1744+ , benchIO "MonadState Int m => SerialT m Int" $ \n ->
1745+ State.evalStateT (S.drain (iterateState n)) value
1746+ ]
1747+ ]
1748+
16811749-------------------------------------------------------------------------------
16821750-- Main
16831751-------------------------------------------------------------------------------
@@ -1703,6 +1771,7 @@ main = do
17031771 , o_1_space_elimination_multi_stream size
17041772
17051773 -- transformation
1774+ , o_1_space_functor size
17061775 , o_1_space_mapping size
17071776 , o_1_space_mappingX4 size
17081777 , o_1_space_filtering size
@@ -1747,7 +1816,9 @@ main = do
17471816 , o_n_space_grouping size
17481817
17491818 -- multi-stream
1819+ , o_n_space_functor size
17501820 , o_n_space_applicative size
17511821 , o_n_space_monad size
1822+ , o_n_space_transformer size
17521823 ]
17531824 ]