Распараллеливание оценки и точечное добавление списков - PullRequest
Новая
       39

Распараллеливание оценки и точечное добавление списков

1 голос
/ 17 февраля 2020

У меня есть следующий код: 

normalHands :: [[[Char]]]
normalHands = -- a very long list

sevenHeads :: [[[Char]]]
sevenHeads = -- a very long list

countYakus :: [Int]
countYakus = foldr countYaku [0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0] (normalHands ++ sevenHeads) where
    countYaku hand [p,oP,dT,aS,cS,fS,sO,cF,cT,dM,aO,tOAK,tP,sT,sF,f] =
    -- involves pointwise addition of lists. The length of the accumulator is not changed.

Как мне распараллелить это? Я попробовал следующее: 

import Control.Concurrent
import Control.Concurrent.QSem
import Control.Monad
import Data.List

--...

main :: IO ()
main = let
    [pinfu, onePair, dragonTriplet, allSimples,
        colorfulSequences, fullSequence, semiOrphans, concealedFour, colorfulTriplets, dragonsMinor, allOrphans, threeOfAKind,
        twoPairs, semiTerminals, semiFlush, flush] = countYakus
    in do
        qSem <- newQSem 0
        forkIO $ putStrLn ("0: " ++ show pinfu ++ ' ' : show onePair) >> signalQSem qSem
        forkIO $ putStrLn ("1: " ++ show dragonTriplet ++ ' ' : show allSimples) >> signalQSem qSem
        forkIO $ putStrLn ("2: " ++ show colorfulSequences ++ ' ' : show fullSequence) >> signalQSem qSem
        forkIO $ putStrLn ("3: " ++ show semiOrphans ++ ' ' : show concealedFour) >> signalQSem qSem
        forkIO $ putStrLn ("4: " ++ show colorfulTriplets ++ ' ' : show dragonsMinor) >> signalQSem qSem
        forkIO $ putStrLn ("5: " ++ show allOrphans ++ ' ' : show threeOfAKind) >> signalQSem qSem
        forkIO $ putStrLn ("6: " ++ show twoPairs ++ ' ' : show semiTerminals) >> signalQSem qSem
        forkIO $ putStrLn ("7: " ++ show semiFlush ++ ' ' : show flush) >> signalQSem qSem
        sequence_ $ replicate 8 (waitQSem qSem)

Я скомпилировал это с -O2 +RTS -N8, но, несмотря на то, что у меня 8 ядер, мой системный монитор ясно показывает, что этот код выполняется только в одном ядре. Я думаю, это из-за normalHands ++ sevenHeads. Итак, как правильно распараллелить это?

РЕДАКТИРОВАТЬ: Используя ассоциативность и коммутативность точечного сложения, я попробовал это: 

countYakus :: [[[Char]]] -> [Int]
countYakus = foldl' countYaku [0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0] where
    -- ...


divideList :: Int -> [a] -> [[a]]
divideList 0 _ = []
divideList n xs = let
    (ys,zs) = splitAt n xs
    in if null zs
        then coZip ys (replicate n [])
        else coZip ys (divideList n zs)
  where
    coZip :: [a] -> [[a]] -> [[a]]
    coZip [] yss = yss
    coZip (x:xs) (ys:yss) = (x:ys) : coZip xs yss

main :: IO ()
main = do
    acc <- newIORef [0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0]
    mapM_ (\hands -> forkIO . atomicModifyIORef' acc $ \cs -> (zipWith (+) cs $ countYakus hands, ())) $ divideList 8 (normalHands ++ sevenHeads)
    cs <- readIORef acc
    mapM_ (putStrLn . show) cs

Но он все еще работает только на одном ядре.

РЕДАКТИРОВАТЬ 2: Я пытался использовать MVar: 

main :: IO ()
main = do
    acc <- newIORef [0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0]
    mVar <- newEmptyMVar
    mapM_ (\hands -> forkIO $ putMVar mVar (countYakus hands)) $ divideList 8 (normalHands ++ sevenHeads)
    replicateM_ 8 $ do
        xs <- takeMVar mVar
        ys <- readIORef acc
        writeIORef acc (zipWith (+) xs ys)
    cs <- readIORef acc
    mapM_ (putStrLn . show) cs

Но он все еще работает только на одном ядре.

...