QSemはスレッドをブロックしていないようです

Question

Shellyライブラリを使用して複数のタスクを並行して実行する簡単なスクリプトを作成していますが、一度に実行するタスクの最大数を制限します。このスクリプトは、各行の入力ファイルを受け取り、その入力に対してタスクを実行します。ファイルには数百の入力があり、一度に約16個のプロセスに制限したいと考えています。

：

現在のスクリプトは、実際に私は4つの入力とテストファイル上で実行したときに、私はこれを見るために私も何かが欠けているように見える1の初期カウントでQSemを使用して（良くしようとする）を1に制限します

 
Starting 
Starting 
Starting 
Starting 
Done 
Done 
Done 
Done 

スレッドがQSem上でブロックしないように、これらはすべて同時に実行されています。私は今まで自分のセマフォーを実装するために、MVarとTVarの両方に行ってしまっていましたが、どちらも期待通りに動作しませんでした。私は明らかに根本的な何かを欠いているが何？また、コードをコンパイルしてバイナリとして実行しようとしました。

 
#!/usr/bin/env runhaskell 
{-# LANGUAGE TemplateHaskell, QuasiQuotes, DeriveDataTypeable, OverloadedStrings #-} 

import Shelly 
import Prelude hiding (FilePath) 
import Text.Shakespeare.Text (lt) 
import qualified Data.Text.Lazy as LT 
import Control.Monad (forM) 
import System.Environment (getArgs) 

import qualified Control.Concurrent.QSem as QSem 
import Control.Concurrent (forkIO, MVar, putMVar, newEmptyMVar, takeMVar) 

-- Define max number of simultaneous processes 
maxProcesses :: IO QSem.QSem 
maxProcesses = QSem.newQSem 1 

bkGrnd :: ShIO a -> ShIO (MVar a) 
bkGrnd proc = do 
    mvar <- liftIO newEmptyMVar 
    _ <- liftIO $ forkIO $ do 
    -- Block until there are free processes 
    sem <- maxProcesses 
    QSem.waitQSem sem 
    putStrLn "Starting" 
    -- Run the shell command 
    result <- shelly $ silently proc 
    liftIO $ putMVar mvar result 
    putStrLn "Done" 
    -- Signal that this process is done and another can run. 
    QSem.signalQSem sem 
    return mvar 

main :: IO() 
main = shelly $ silently $ do 
    [img, file] <- liftIO $ getArgs 
    contents <- readfile $ fromText $ LT.pack file 
    -- Run a backgrounded process for each line of input. 
    results <- forM (LT.lines contents) $ \line -> bkGrnd $ do 
     runStdin &ltcommand> &ltarguments> 
    liftIO $ mapM_ takeMVar results 

Answer 1

私は私のコメントで言ったように、bkGrndへの各呼び出しは、すべてのスレッドが待機することなく継続することができ、独自のsemaphonreを作成します。私はmainでセマフォが作成され、毎回bkGrndに渡される代わりに、このようなものを試してみます。

bkGrnd :: QSem.QSem -> ShIO a -> ShIO (MVar a) 
bkGrnd sem proc = do 
    mvar <- liftIO newEmptyMVar 
    _ <- liftIO $ forkIO $ do 
    -- Block until there are free processes 
    QSem.waitQSem sem 
    -- 
    -- code continues as before 
    -- 

main :: IO() 
main = shelly $ silently $ do 
    [img, file] <- liftIO $ getArgs 
    contents <- readfile $ fromText $ LT.pack file 
    sem <- maxProcesses 
    -- Run a backgrounded process for each line of input. 
    results <- forM (LT.lines contents) $ \line -> bkGrnd sem $ do 
     runStdin <command> <arguments> 
    liftIO $ mapM_ takeMVar results 

Answer 2

あなたは答えを持っていますが、私は追加する必要があります。killThreadまたは非同期スレッド死亡が可能な場合QSemとQSemNはスレッドセーフではありません。

私のバグレポートとパッチはGHC trac ticket #3160です。固定コードは、Control.Concurrent.MSem、MSemN、MSampleVar、およびボーナスFairRWLockモジュールを使用してSafeSemaphoreという新しいライブラリとして利用できます。あなたがセマフォを取得するまで

Answer 3

はそれが

bkGrnd sem proc = do 
    QSem.waitQSem sem 
    mvar <- liftIO newEmptyMVar 
    _ <- liftIO $ forkIO $ do 
    ... 

より良いそうもない forkIOはありませんか？