| dist | |
| dist-newstyle | |
| .ghc.environment.* |
❯ cabal new-run
Up to date
create
... connection used
destroy
resource-pool-error(61409,0x70000394e000) malloc: *** error for object 0xc000000000000000: pointer being freed was not allocated
resource-pool-error(61409,0x70000394e000) malloc: *** set a breakpoint in malloc_error_break to debug
zsh: abort cabal new-run
on macOS
| constraints: any.Cabal ==2.4.0.1, | |
| any.HDBC ==2.4.0.3, | |
| HDBC -buildtests +mintime15 +splitbase, | |
| any.HDBC-postgresql ==2.3.2.7, | |
| HDBC-postgresql -buildtests +mintime15 +splitbase, | |
| any.array ==0.5.3.0, | |
| any.base ==4.12.0.0, | |
| any.base-orphans ==0.8.1, | |
| any.binary ==0.8.6.0, | |
| any.bytestring ==0.10.8.2, | |
| any.containers ==0.6.0.1, | |
| any.convertible ==1.1.1.0, | |
| convertible -buildtests, | |
| any.deepseq ==1.4.4.0, | |
| any.directory ==1.3.3.0, | |
| any.filepath ==1.4.2.1, | |
| any.ghc-prim ==0.5.3, | |
| any.hashable ==1.3.0.0, | |
| hashable -examples +integer-gmp +sse2 -sse41, | |
| any.integer-gmp ==1.0.2.0, | |
| any.monad-control ==1.0.2.3, | |
| any.mtl ==2.2.2, | |
| any.old-locale ==1.0.0.7, | |
| any.old-time ==1.1.0.3, | |
| any.parsec ==3.1.13.0, | |
| any.pretty ==1.1.3.6, | |
| any.primitive ==0.7.0.0, | |
| any.process ==1.6.5.0, | |
| any.resource-pool ==0.2.3.2, | |
| resource-pool -developer, | |
| any.rts ==1.0, | |
| any.stm ==2.5.0.0, | |
| any.text ==1.2.3.1, | |
| any.time ==1.8.0.2, | |
| any.transformers ==0.5.6.2, | |
| any.transformers-base ==0.4.5.2, | |
| transformers-base +orphaninstances, | |
| any.transformers-compat ==0.6.5, | |
| transformers-compat -five +five-three -four +generic-deriving +mtl -three -two, | |
| any.unix ==2.7.2.2, | |
| any.utf8-string ==1.0.1.1, | |
| any.vector ==0.12.0.3, | |
| vector +boundschecks -internalchecks -unsafechecks -wall |
| Copyright (c) 2019, amutake | |
| All rights reserved. | |
| Redistribution and use in source and binary forms, with or without | |
| modification, are permitted provided that the following conditions are met: | |
| * Redistributions of source code must retain the above copyright | |
| notice, this list of conditions and the following disclaimer. | |
| * Redistributions in binary form must reproduce the above | |
| copyright notice, this list of conditions and the following | |
| disclaimer in the documentation and/or other materials provided | |
| with the distribution. | |
| * Neither the name of amutake nor the names of other | |
| contributors may be used to endorse or promote products derived | |
| from this software without specific prior written permission. | |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS | |
| "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT | |
| LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR | |
| A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT | |
| OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, | |
| SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT | |
| LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, | |
| DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY | |
| THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT | |
| (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE | |
| OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. |
| module Main where | |
| import Control.Concurrent (threadDelay, forkIO) | |
| import Control.Concurrent.STM.TVar | |
| import Control.Monad (replicateM, forM_, forM) | |
| import Control.Monad.STM | |
| import Data.IntMap hiding (map) | |
| import Data.Pool | |
| import Database.HDBC (disconnect) | |
| import Database.HDBC.PostgreSQL (connectPostgreSQL, Connection) | |
| main :: IO () | |
| main = do | |
| let numPool = 100 | |
| let numMkConnPerPool = 10 | |
| let sizePerPool = 10 | |
| tvar <- mk numPool | |
| pools <- forM [1..numPool] $ \poolId -> createPool | |
| (create tvar poolId) | |
| destroy | |
| 1 -- num of stripes | |
| 0.5 -- idle time | |
| sizePerPool -- pool size | |
| forM_ pools $ \pool -> forM_ [1..numMkConnPerPool] $ \n -> forkIO $ | |
| withResource pool $ \(_conn, poolId, connId) -> do | |
| putStrLn $ "using connection: " ++ show (poolId, connId, n) | |
| threadDelay $ 1 * 1000 -- * 1000 | |
| putStrLn $ "done: " ++ show (poolId, connId, n) | |
| threadDelay $ 2 * 1000 * 1000 | |
| putStrLn "*** done" | |
| create :: TVar (IntMap Int) -> Int -> IO (Connection, Int, Int) | |
| -- create :: TVar (IntMap Int) -> Int -> IO (Int, Int, Int) | |
| create tvar poolId = do | |
| connId <- inc tvar poolId | |
| putStrLn $ "*** create: " ++ show (poolId, connId) | |
| conn <- connectPostgreSQL "postgres:///resource-pool-error" | |
| -- conn <- return 0 | |
| return (conn, poolId, connId) | |
| destroy :: (Connection, Int, Int) -> IO () | |
| -- destroy :: (Int, Int, Int) -> IO () | |
| destroy (conn, poolId, connId) = do | |
| putStrLn $ "*** destroy: " ++ show (poolId, connId) | |
| disconnect conn | |
| -- return () | |
| mk :: Int -> IO (TVar (IntMap Int)) | |
| mk size = newTVarIO (fromList $ map (\p -> (p, 1)) [1..size]) | |
| inc :: TVar (IntMap Int) -> Int -> IO Int | |
| inc tvar poolId = do | |
| (Just n) <- atomically $ stateTVar tvar $ updateLookupWithKey (\_ n -> Just (n + 1)) poolId | |
| return n |
| cabal-version: 2.4 | |
| -- Initial package description 'resource-pool-error.cabal' generated by | |
| -- 'cabal init'. For further documentation, see | |
| -- http://haskell.org/cabal/users-guide/ | |
| name: resource-pool-error | |
| version: 0.1.0.0 | |
| -- synopsis: | |
| -- description: | |
| -- bug-reports: | |
| license: BSD-3-Clause | |
| license-file: LICENSE | |
| author: amutake | |
| maintainer: amutake.s@gmail.com | |
| -- copyright: | |
| -- category: | |
| extra-source-files: CHANGELOG.md | |
| executable resource-pool-error | |
| main-is: Main.hs | |
| -- other-modules: | |
| -- other-extensions: | |
| build-depends: base ^>=4.12.0.0, | |
| resource-pool, | |
| stm, | |
| containers, | |
| HDBC, | |
| HDBC-postgresql | |
| hs-source-dirs: . | |
| default-language: Haskell2010 |
| import Distribution.Simple | |
| main = defaultMain |
disconnect を一度しか呼ばなくても、gc で回収されるのとかぶれば起こりうる
https://github.com/hdbc/hdbc-postgresql/blob/master/Database/HDBC/PostgreSQL/Connection.hsc#L68
単純に disconnect を並列に呼んだらだめ。
https://github.com/hdbc/hdbc-postgresql/blob/master/hdbc-postgresql-helper.c#L31-L35
おそらく reaper の処理と purgeLocalPool が並列に呼ばれている？
(もともとのこのコードは threaded をつけ忘れていて気づかなかった。GC のスレッドは別なのでたまに起きていた)