為什么這個Haskell程序在寫入文件時會掛起？

Question

如果使用runhaskell運行或者如果已編譯但未使用-O2則下面的程序可以正常運行。 如果用-O2編譯它似乎掛起。

我正在使用GHC 7.10.2。

我已經將最小/最大迭代次數分別更改為10和20。 它將在文件test.out生成20到100 MB的輸出。 運行時間約為15-60秒。

程序說明

下面是一個多線程程序，它有一個工作池和一個管理器。 工人生成用於繪制Buddhabrot的痕跡，將其放入隊列中，並且管理員定期清空隊列並將數據寫入磁盤。 生成一定數量的數據后，程序停止。

但是當程序運行時，管理器線程只進行一次檢查，然后它就會卡住（工作線程仍在運行）。 但是，如果我刪除管理器線程寫入文件的部分，那么一切似乎都有效。 我只是不明白為什么......

import Control.Concurrent
import Control.Concurrent.Async
import Control.Concurrent.STM
import Control.Monad
  ( forever
  , unless
  )
import Control.Monad.Loops
import System.IO
import System.Random

import qualified Data.Binary as B
import qualified Data.ByteString.Lazy as BS

type Coord = (Double, Double)

type Trace = [Coord]

-- | Represents a rectangle in the complex plane, bounded by a lower left
-- coordinate and an upper right coordinate.
data Plane
  = Plane { ll :: Coord, ur :: Coord }
  deriving (Show)

-- | Adds two coordinates.
(+.) :: Coord -> Coord -> Coord
(r1, i1) +. (r2, i2) = (r1 + r2, i1 + i2)

-- | Multiplies two coordinates.
(*.) :: Coord -> Coord -> Coord
(r1, i1) *. (r2, i2) = (r1*r2 - i1*i2, r1*i2 + r2*i1)

-- | Computes the square of a coordinate.
square :: Coord -> Coord
square (r, i) = (r*r - i*i, 2*r*i)

-- | Distance from origin to a given coordinate.
distFromOrigin :: Coord -> Double
distFromOrigin (r, i) = r*r + i*i

-- | A structure for passing data to the worker threads.
data WorkerData
  = WorkerData { wdMinIt :: Int
               , wdMaxIt :: Int
               , wdTraceQueue :: TQueue Trace
                 -- ^ A queue of traces to be written to disk.
               }

-- | A structure for passing data to the manager thread.
data ManagerData
  = ManagerData { mdOutHandle :: Handle
                   -- ^ Handle to the output file.
                , mdNumTraces :: Integer
                  -- ^ Number of traces to gather.
                , mdTraceQueue :: TQueue Trace
                  -- ^ A queue of traces to be written to disk.
                }

-- | Encodes an entity to binary bytestring.
encode :: B.Binary a => a -> BS.ByteString
encode = B.encode

-- | Writes a lazy bytestring to file.
writeToFile :: Handle -> BS.ByteString -> IO ()
writeToFile = BS.hPut

mkManagerData :: TQueue Trace -> IO ManagerData
mkManagerData t_queue =
  do let out_f = "test.out"
     out_h <- openBinaryFile out_f WriteMode
     let num_t = 1000
     return $ ManagerData { mdOutHandle = out_h
                          , mdNumTraces = num_t
                          , mdTraceQueue = t_queue
                          }

mkWorkerData :: TQueue Trace -> IO WorkerData
mkWorkerData t_queue =
  do let min_it =  10 -- 1000
         max_it =  20 -- 10000
     return $ WorkerData { wdMinIt = min_it
                         , wdMaxIt = max_it
                         , wdTraceQueue = t_queue
                         }

-- | The actions to be performed by the manager thread.
runManager :: ManagerData -> IO ()
runManager m_data =
  do execute 0
     return ()
  where execute count =
          do new_traces <- purgeTQueue $ mdTraceQueue m_data
             let new_count = count + (toInteger $ length new_traces)
             putStrLn $ "Found " ++ (show $ new_count) ++ " traces so far. "
             if length new_traces > 0
             then do putStrLn $ "Writing new traces to file..."
                     _ <- mapM (writeToFile (mdOutHandle m_data))
                               (map encode new_traces)
                     putStr "Done"
             else return ()
             putStrLn ""
             unless (new_count >= mdNumTraces m_data) $
               do threadDelay (1000 * 1000) -- Sleep 1s
                  execute new_count

-- | The actions to be performed by a worker thread.
runWorker :: WorkerData -> IO ()
runWorker w_data =
  forever $
    do c <- randomCoord
       case computeTrace c (wdMinIt w_data) (wdMaxIt w_data) of
         Just t  -> atomically $ writeTQueue (wdTraceQueue w_data) t
         Nothing -> return ()

-- | Reads all values from a given 'TQueue'. If any other thread reads from the
-- same 'TQueue' during the execution of this function, then this function may
-- deadlock.
purgeTQueue :: Show a => TQueue a -> IO [a]
purgeTQueue q =
  whileJust (atomically $ tryReadTQueue q)
            (return . id)

-- | Generates a random coordinate to trace.
randomCoord :: IO Coord
randomCoord =
  do x <- randomRIO (-2.102613, 1.200613)
     y <- randomRIO (-1.237710, 1.239710)
     return (x, y)

-- | Computes a trace, using the classical Mandelbrot function, for a given
-- coordinate and minimum and maximum iteration count. If the length of the
-- trace is less than the minimum iteration count, or exceeds the maximum
-- iteration count, 'Nothing' is returned.
computeTrace
  :: Coord
  -> Int
     -- ^ Minimum iteration count.
  -> Int
     -- ^ Maximum iteration count.
  -> Maybe Trace
computeTrace c0 min_it max_it =
  if isUsefulCoord c0
  then let step c = square c +. c0
           computeIt c it = if it < max_it
                            then computeIt (step c) (it + 1)
                            else it
           computeTr [] = error "computeTr: empty list"
           computeTr (c:cs) = if length cs < max_it
                              then computeTr (step c:(c:cs))
                              else (c:cs)
           num_it = computeIt c0 0
       in if num_it >= min_it && num_it <= max_it
          then Just $ reverse $ computeTr [c0]
          else Nothing
  else Nothing

-- | Checks if a given coordinate is useful by checking if it belongs in the
-- cardioid or period-2 bulb of the Mandelbrot.
isUsefulCoord :: Coord -> Bool
isUsefulCoord (x, y) =
  let t1 = x - 1/4
      p = sqrt (t1*t1 + y*y)
      is_in_cardioid = x < p - 2*p*p + 1/4
      t2 = x + 1
      is_in_bulb = t2*t2 + y*y < 1/16
  in not is_in_cardioid && not is_in_bulb

main :: IO ()
main =
  do t_queue <- newTQueueIO
     m_data <- mkManagerData  t_queue
     w_data <- mkWorkerData t_queue
     let num_workers = 1
     workers <- mapM async (replicate num_workers (runWorker w_data))
     runManager m_data
     _ <- mapM cancel workers
     _ <- mapM waitCatch workers
     putStrLn "Tracing finished"

為什么失敗

在回顧下面的答案之后，我終於意識到為什么它不能按預期工作。 程序沒有掛起，但是管理器線程對單個跟蹤進行編碼所花費的時間大約為幾十秒（編碼時耗費幾兆字節）！ 這意味着即使在耗盡時隊列中有數十條跡線 - 在我的機器上，工作人員在隊列被管理器線程耗盡之前設法產生大約250條跡線 - 它將在下一次排氣之前永遠消耗。

因此，除非管理器線程的工作大大減少，否則我選擇的解決方案很少。 為此，我將不得不放棄將每個單獨的跟蹤轉儲到文件的想法，而是在生成后處理它。

Answer 1

問題是雙重的：

（1）管理器線程在耗盡隊列之前不處理任何跟蹤。

（2）工作線程可以非常快速地向隊列中添加元素。

這導致管理者線程很少獲勝的競賽。 [這也解釋了觀察到的-O2行為 - 優化只是使工作線程更快。 ]

添加一些調試代碼表明，worker可以向隊列添加超過每秒100K Traces的項目。 此外，即使經理只對寫出前1000個痕跡感興趣，工人也不會停留在這個限制。 因此，在某些情況下，經理永遠無法退出此循環：

purgeTQueue q = whileJust (atomically $ tryReadTQueue q) (return . id)

修復代碼的最簡單方法是讓管理器線程使用readTQueue只讀取和處理隊列中的一個項目。 這也將阻塞管理器線程，當隊列為空時，不需要經理線程定期休眠。

將purgeTQueue更改為：

purgeTQueue = do item <- atomically $ readTQueue (mdTraceQueue m_data)
                 return [item]

從runManager刪除threadDelay runManager解決問題。

Lib4.hs模塊中提供的示例代碼： https ： //github.com/erantapaa/mandel