diff --git a/.gitignore b/.gitignore index fa4e5f0..c81c401 100644 --- a/.gitignore +++ b/.gitignore @@ -25,3 +25,6 @@ cabal.project.local # datasets *.csv + +# profiling artifacts +*.ps diff --git a/app/Performance.hs b/app/Performance.hs new file mode 100644 index 0000000..d27dec0 --- /dev/null +++ b/app/Performance.hs @@ -0,0 +1,86 @@ +import Control.Monad (forever) +import Deli (Channel, Deli, JobTiming(..)) +import Deli.Printer (printResults) +import System.Random +import qualified Deli + +singleQueue + :: Channel JobTiming + -> Deli JobTiming () +singleQueue queue = + forever $ do + job <- Deli.readChannel queue + Deli.runJob job + +singleQueueExample :: IO () +singleQueueExample = do + gen <- newStdGen + let durations = repeat 0.5 + count = 1000 * 100 + times = [0,1..(count - 1)] + jobs = zipWith JobTiming times durations + res = Deli.simulate gen jobs singleQueue + printResults res + +chainedQueues + :: Channel JobTiming + -> Deli JobTiming () +chainedQueues queue = do + middleChan <- Deli.newChannel Nothing + Deli.fork $ forever $ do + job <- Deli.readChannel middleChan + Deli.runJob job + forever $ do + job <- Deli.readChannel queue + Deli.writeChannel middleChan job + +chainedQueueExample :: IO () +chainedQueueExample = do + gen <- newStdGen + let durations = repeat 0.5 + count = 1000 * 100 + times = [0,1..(count - 1)] + jobs = zipWith JobTiming times durations + res = Deli.simulate gen jobs chainedQueues + printResults res + +oneThread + :: Channel JobTiming + -> Deli JobTiming () +oneThread queue = do + middleChan <- Deli.newChannel Nothing + forever $ do + jobA <- Deli.readChannel queue + Deli.writeChannel middleChan jobA + jobB <- Deli.readChannel middleChan + Deli.runJob jobB + +oneThreadExample :: IO () +oneThreadExample = do + gen <- newStdGen + let durations = repeat 0.5 + count = 1000 * 100 + times = [0,1..(count - 1)] + jobs = zipWith JobTiming times durations + res = Deli.simulate gen jobs oneThread + printResults res + +main :: IO () +main = do + newline + putStrLn "## singleQueueExample ##" + newline + singleQueueExample + newline + + putStrLn "## chainedQueueExample ##" + newline + chainedQueueExample + newline + + putStrLn "## oneThreadExample ##" + newline + oneThreadExample + newline + + where newline = putStrLn "\n" diff --git a/deli.cabal b/deli.cabal index 1923e11..be582d7 100644 --- a/deli.cabal +++ b/deli.cabal @@ -56,13 +56,13 @@ executable tutorial default-language: Haskell2010 ghc-options: -threaded -rtsopts -with-rtsopts=-N -O1 -test-suite deli-test - type: exitcode-stdio-1.0 - hs-source-dirs: test - main-is: Spec.hs +executable performance + hs-source-dirs: app + main-is: Performance.hs build-depends: base , deli - ghc-options: -threaded -rtsopts -with-rtsopts=-N + , random + ghc-options: -rtsopts default-language: Haskell2010 source-repository head diff --git a/src/Control/Monad/Concurrent.hs b/src/Control/Monad/Concurrent.hs index 1b670e4..2e36d6e 100644 --- a/src/Control/Monad/Concurrent.hs +++ b/src/Control/Monad/Concurrent.hs @@ -449,6 +449,7 @@ iwriteChannel chan@(Channel _ident mMaxSize) item = do Just ((readerId, nextReader), newReaders) -> do channels . ix chan . readers .= newReaders local (const readerId) nextReader + register (ischeduleDuration 0 myId) writeChannelNonblocking :: Monad m diff --git a/test/Spec.hs b/test/Spec.hs deleted file mode 100644 index cd4753f..0000000 --- a/test/Spec.hs +++ /dev/null @@ -1,2 +0,0 @@ -main :: IO () -main = putStrLn "Test suite not yet implemented"