Skip to content

Commit

Permalink
Browse files Browse the repository at this point in the history
Demonstrate poorly firing rewrite rules
  • Loading branch information
snoyberg committed Aug 15, 2014
1 parent 9e9f8d0 commit a62e7eb
Show file tree
Hide file tree
Showing 2 changed files with 63 additions and 4 deletions.
66 changes: 62 additions & 4 deletions conduit/benchmarks/optimize-201408.hs
Expand Up @@ -7,9 +7,13 @@
import Control.DeepSeq
import Control.Monad (foldM)
import Control.Monad (when)
import Control.Monad.Codensity (lowerCodensity)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Trans.Class (lift)
import Criterion.Main
import Data.Conduit
import Data.Conduit.Internal (ConduitM (..), Pipe (..))
import qualified Data.Conduit.Internal as CI
import qualified Data.Conduit.List as CL
import qualified Data.Foldable as F
import Data.Functor.Identity (runIdentity)
Expand Down Expand Up @@ -116,14 +120,46 @@ monteCarloTB = return $ TBGroup "monte carlo"
| otherwise = t
go (i - 1) t'
go count (0 :: Int)
, TBIOTest "conduit" closeEnough $ do
, TBIOTest "conduit, ConduitM primitives" closeEnough $ do
successes <- sourceRandomN count
$$ CL.fold (\t (x, y) ->
if (x*x + y*(y :: Double) < 1)
then t + 1
else t)
(0 :: Int)
return $ fromIntegral successes / fromIntegral count * 4
, TBIOTest "conduit, ConduitM primitives, Codensity" closeEnough $ lowerCodensity $ do
successes <- sourceRandomN count
$$ CL.fold (\t (x, y) ->
if (x*x + y*(y :: Double) < 1)
then t + 1
else t)
(0 :: Int)
return $ fromIntegral successes / fromIntegral count * 4
, TBIOTest "conduit, ConduitM primitives, explicit binding order" closeEnough $ do
successes <- sourceRandomNBind count
$$ CL.fold (\t (x, y) ->
if (x*x + y*(y :: Double) < 1)
then t + 1
else t)
(0 :: Int)
return $ fromIntegral successes / fromIntegral count * 4
, TBIOTest "conduit, Pipe primitives" closeEnough $ do
successes <- sourceRandomNPipe count
$$ CL.fold (\t (x, y) ->
if (x*x + y*(y :: Double) < 1)
then t + 1
else t)
(0 :: Int)
return $ fromIntegral successes / fromIntegral count * 4
, TBIOTest "conduit, Pipe constructos" closeEnough $ do
successes <- sourceRandomNConstr count
$$ CL.fold (\t (x, y) ->
if (x*x + y*(y :: Double) < 1)
then t + 1
else t)
(0 :: Int)
return $ fromIntegral successes / fromIntegral count * 4
]
where
count = 100000 :: Int
Expand All @@ -137,9 +173,31 @@ sourceRandomN cnt0 = do
gen <- liftIO MWC.createSystemRandom
let loop 0 = return ()
loop cnt = do
x <- liftIO $ MWC.uniform gen
yield x
loop (cnt - 1)
liftIO (MWC.uniform gen) >>= yield >> loop (cnt - 1)
loop cnt0

sourceRandomNBind :: (MWC.Variate a, MonadIO m) => Int -> Source m a
sourceRandomNBind cnt0 = lift (liftIO MWC.createSystemRandom) >>= \gen ->
let loop 0 = return ()
loop cnt = do
lift (liftIO $ MWC.uniform gen) >>= (\o -> yield o >> loop (cnt - 1))
in loop cnt0

sourceRandomNPipe :: (MWC.Variate a, MonadIO m) => Int -> Source m a
sourceRandomNPipe cnt0 = ConduitM $ do
gen <- liftIO MWC.createSystemRandom
let loop 0 = return ()
loop cnt = do
liftIO (MWC.uniform gen) >>= CI.yield >> loop (cnt - 1)
loop cnt0

sourceRandomNConstr :: (MWC.Variate a, MonadIO m) => Int -> Source m a
sourceRandomNConstr cnt0 = ConduitM $ PipeM $ do
gen <- liftIO MWC.createSystemRandom
let loop 0 = return $ Done ()
loop cnt = do
x <- liftIO (MWC.uniform gen)
return $ HaveOutput (PipeM $ loop (cnt - 1)) (return ()) x
loop cnt0

-----------------------------------------------------------------------
Expand Down
1 change: 1 addition & 0 deletions conduit/conduit.cabal
Expand Up @@ -82,6 +82,7 @@ benchmark optimize-201408
, hspec
, mwc-random
, criterion
, kan-extensions
main-is: optimize-201408.hs
ghc-options: -Wall -O2 -rtsopts

Expand Down

0 comments on commit a62e7eb

Please sign in to comment.