Qu'est-ce qui ne va pas avec la solution suivante aux "Philosophes à manger"?

Question

Afin de se familiariser avec la STM en Haskell, j'ai écrit la solution suivante à la salle à Philosophes problème:

import Control.Concurrent 
import Control.Concurrent.STM 
import Control.Monad 
import System.Random 

type Fork = TVar Bool 
type StringBuffer = TChan String 

philosopherNames :: [String] 
philosopherNames = map show ([1..] :: [Int]) 

logThinking :: String -> StringBuffer -> STM() 
logThinking name buffer = writeTChan buffer $ name ++ " is thinking..." 

logEating :: String -> StringBuffer -> STM() 
logEating name buffer = writeTChan buffer $ name ++ " is eating..." 

firstLogEntry :: StringBuffer -> STM String 
firstLogEntry buffer = do empty <- isEmptyTChan buffer 
          if empty then retry 
            else readTChan buffer 

takeForks :: Fork -> Fork -> STM() 
takeForks left right = do leftUsed <- readTVar left 
          rightUsed <- readTVar right 
          if leftUsed || rightUsed 
          then retry 
          else do writeTVar left True 
            writeTVar right True 

putForks :: Fork -> Fork -> STM() 
putForks left right = do writeTVar left False 
         writeTVar right False 

philosopher :: String -> StringBuffer -> Fork -> Fork -> IO() 
philosopher name out left right = do atomically $ logThinking name out 
            randomDelay 
            atomically $ takeForks left right 
            atomically $ logEating name out 
            randomDelay 
            atomically $ putForks left right 

randomDelay :: IO() 
randomDelay = do delay <- getStdRandom(randomR (1,3)) 
       threadDelay (delay * 1000000) 

main :: IO() 
main = do let n = 8 
      forks <- replicateM n $ newTVarIO False 
      buffer <- newTChanIO 
      forM_ [0 .. n - 1] $ \i -> 
       do let left = forks !! i 
        right = forks !! ((i + 1) `mod` n) 
        name = philosopherNames !! i 
       forkIO $ forever $ philosopher name buffer left right 

      forever $ do str <- atomically $ firstLogEntry buffer 
         putStrLn str 

Quand je compile et exécute ma solution, il semble que pas de problèmes de concurrence évidentes existent: Chaque philosophe finalement manger et aucun philosophe ne semble être favorisé. Cependant, si je retire les déclarations de randomDelayphilosopher, compiler et exécuter, la sortie de mon programme se présente comme suit:

1 is thinking... 
1 is eating... 
1 is thinking... 
1 is eating... 
2 is thinking... 
2 is eating... 
2 is thinking... 
2 is eating... 
2 is thinking... 
2 is eating... 
2 is thinking... 

About 2500 lines later... 

2 is thinking... 
2 is eating... 
2 is thinking... 
3 is thinking... 
3 is eating... 
3 is thinking... 
3 is eating... 

And so on... 

ce qui se passe dans ce cas?

Answer 1

Vous devez compiler avec le moteur d'exécution fileté et activé rtsopts, et l'exécuter avec +RTS -N (ou +RTS -Nk où k est le nombre de threads. Avec cela, je reçois une sortie comme

8 is eating... 
6 is eating... 
4 is thinking... 
6 is thinking... 
4 is eating... 
7 is eating... 
8 is thinking... 
4 is thinking... 
7 is thinking... 
8 is eating... 
4 is eating... 
4 is thinking... 
4 is eating... 
6 is eating... 
4 is thinking... 

Le point est que pour qu'un autre philosophe pense/mange, un changement de contexte doit avoir lieu si vous n'avez pas plusieurs threads matériels à votre disposition, un tel changement de contexte ne se produit pas souvent ici, où peu d'allocation est faite, donc chaque philosophe a beaucoup de temps pour réfléchir et manger beaucoup avant que le tour suivant ne se produise:

Avec assez de threads à votre disposition, tous les philosophes peuvent simultanément tenter d'atteindre les fourchettes.