Pool.hs

module Test.Pool(main) where

import Test.Type
import General.Pool

import Control.Concurrent.Extra
import Control.Exception.Extra
import Control.Monad
import System.Time.Extra
import Data.Either.Extra
import General.Timing


main = testSimple $ do
    -- See #474, we should never be running pool actions masked
    let add pool act = addPool PoolStart pool $ do
            Unmasked <- getMaskingState
            act

    forM_ [False,True] $ \deterministic -> do
        -- check that it aims for exactly the limit
        forM_ [1..6] $ \n -> do
            var <- newVar (0,0) -- (maximum, current)
            runPool deterministic n $ \pool ->
                replicateM_ 5 $
                    add pool $ do
                        modifyVar_ var $ \(mx,now) -> pure (max (now+1) mx, now+1)
                        -- requires that all tasks get spawned within 0.1s
                        sleep 0.1
                        modifyVar_ var $ \(mx,now) -> pure (mx,now-1)
            res <- readVar var
            res === (min n 5, 0)

        -- check that exceptions are immediate
        good <- newVar True
        started <- newBarrier
        stopped <- newBarrier
        res <- try_ $ runPool deterministic 3 $ \pool -> do
                add pool $ do
                    waitBarrier started
                    throwIO Underflow
                add pool $
                    flip finally (signalBarrier stopped ()) $ do
                        signalBarrier started ()
                        sleep 10
                        modifyVar_ good $ const $ pure False
        -- note that the pool finishing means we started killing our threads
        -- not that they have actually died
        mapLeft fromException res === Left (Just Underflow)
        waitBarrier stopped
        assertBoolIO (readVar good) "Must be true"

        -- check someone spawned when at zero todo still gets run
        done <- newBarrier
        runPool deterministic 1 $ \pool ->
            add pool $
                add pool $
                    signalBarrier done ()
        assertWithin 1 $ waitBarrier done

        -- check high priority stuff runs first
        res <- newVar ""
        runPool deterministic 1 $ \pool -> do
            let note c = modifyVar_ res $ pure . (c:)
            -- deliberately in a random order
            addPool PoolBatch pool $ note 'b'
            addPool PoolException pool $ note 'e'
            addPool PoolStart pool $ note 's'
            addPool PoolStart pool $ note 's'
            addPool PoolResume pool $ note 'r'
            addPool PoolException pool $ note 'e'
        (=== "bssree") =<< readVar res

        -- check that killing a thread pool stops the tasks, bug 545
        -- and propagates the right exception
        thread <- newBarrier
        died <- newBarrier
        done <- newBarrier
        t <- flip forkFinally (signalBarrier died) $ runPool deterministic 1 $ \pool ->
            add pool $
                flip onException (signalBarrier done ()) $ do
                    flip throwTo Overflow =<< waitBarrier thread
                    sleep 10
        signalBarrier thread t
        assertWithin 1 $ waitBarrier done
        res <- assertWithin 1 $ waitBarrier died
        mapLeft fromException res === Left (Just Overflow)

        -- check that killing a thread pool aborts all threads before it returns
        started <- newBarrier
        var <- newVar False
        try_ $ runPool deterministic 2 $ \pool -> do
            add pool $ try_ $ (do signalBarrier started (); sleep 10) `finally` (do sleep 1; writeVar var True)
            add pool $ do waitBarrier started; throw Overflow
        (=== True) =<< readVar var

    -- benchmark for testing thread performance, see https://github.com/ndmitchell/shake/pull/751
    when False $ do
        resetTimings
        withNumCapabilities 4 $ do
            (d, _) <- duration $ runPool False 4 $ \pool ->
                replicateM_ 200000 $ addPool PoolStart pool $ pure ()
            print d
            print =<< getTimings