Skip to content

Instantly share code, notes, and snippets.

@codygman
Last active March 13, 2021 00:37
Show Gist options
  • Save codygman/85431fc57c2a729b1527410f661f0605 to your computer and use it in GitHub Desktop.
Save codygman/85431fc57c2a729b1527410f661f0605 to your computer and use it in GitHub Desktop.
Why isn't withResource blocking?

I get output like:

/tmp $ stack exec --resolver lts-17.5 --package resource-pool --package stm --package hslogger --package time --package concurrent-output -- ghc -O2 -threaded -fwarn-unused-imports testpool.hs && ./testpool
acquire 0 - .81428
acquire 1 - .81431
acquire 2 - .81438
acquire 3 - .81440
acquire 4 - .81448
ThreadId 8:  processing 1 - .82460
ThreadId 17:  processing 4 - .82461
ThreadId 11:  processing 2 - .82464
ThreadId 14:  processing 3 - .82464
ThreadId 5:  processing 0 - .82465
anything else?
release 4 - .14427
release 3 - .14430
release 2 - .14431
release 1 - .14431
release 0 - .14432
anything else?
anything else?

I expect output like:

/tmp $ stack exec --resolver lts-17.5 --package resource-pool --package stm --package hslogger --package time --package concurrent-output -- ghc -O2 -threaded -fwarn-unused-imports testpool.hs && ./testpool
[1 of 1] Compiling Main             ( testpool.hs, testpool.o )
Linking testpool ...
acquire 0
ThreadId 5:  processing 0 - .01129
release 0
acquire 1 -- I thought this would have blocked until 0 was released
ThreadId 8:  processing 1 - .01120
release 1
acquire 2
ThreadId 11:  processing 2 - .01123
release 2
acquire 3
ThreadId 14:  processing 3 - .01129
release 3
acquire 4
ThreadId 17:  processing 4 - .01129
release 4
anything else?
anything else?
anything else?
#!/usr/bin/env stack
-- stack script --resolver lts-14.27 --package resource-pool --package stm --package hslogger --package time --package concurrent-output
import Control.Concurrent
import Control.Concurrent.Async
import Control.Concurrent.STM
import Data.Pool
import Data.Time
import System.Console.Concurrent
import System.Clock
main :: IO ()
main = do
counter <- newTVarIO 0
let acquire = do
k <- atomically $ do
k <- readTVar counter
writeTVar counter (k + 1)
return k
now <- getTime Monotonic
outputConcurrent ("acquire " ++ show k ++ " - "++ show now ++ "\n")
return k
release k = do
now <- getTime Monotonic
outputConcurrent ("acquire " ++ show k ++ " - "++ show now ++ "\n")
withConcurrentOutput $ do
-- create a pool that only allows 1 resource
pool <- createPool acquire release 1 500 1
replicateConcurrently_ 5 $ do
useResourceFor (seconds 10) pool
-- Why do you need these to see the release messages?
putStrLn "anything else?" >> threadDelay (seconds 5)
putStrLn "anything else?" >> threadDelay (seconds 5)
putStrLn "anything else?" >> threadDelay (seconds 5)
useResourceFor waitSeconds pool = withResource pool $ \i -> do
threadDelay waitSeconds
tid <- myThreadId
now <- getTime Monotonic
outputConcurrent $ show tid <> ": " <> " processing " <> show i <> " - " <> show now <> "\n"
seconds = (* 1000000)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment