From 2a9da36c907da405eb5e889f4fcd519839976fde Mon Sep 17 00:00:00 2001
From: Reid Draper <reiddraper@github.com>
Date: Thu, 2 May 2019 15:04:55 -0700
Subject: [PATCH] Fix space leak in writeChannel

Note: need to probably address this in writeChannelNonblocking, as well.

I don't fully understand what's going on here, but my intuition is that
somehow the combination of `forever` and `writeChannel` wasn't tail
recursive, and so stack space was being built-up. By registering the
writer with the scheduler, and letting the stack unwind (I think...),
this seems to fix the issue.
---
 .gitignore                      |  3 ++
 app/Performance.hs              | 86 +++++++++++++++++++++++++++++++++
 deli.cabal                      | 10 ++--
 src/Control/Monad/Concurrent.hs |  1 +
 test/Spec.hs                    |  2 -
 5 files changed, 95 insertions(+), 7 deletions(-)
 create mode 100644 app/Performance.hs
 delete mode 100644 test/Spec.hs

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"