STMで解く「食事する哲学者の問題」

Haskell で STM を使えばデッドロックがなくなる例として、食事する哲学者の問題を考えてみる。

デッドロックするコード

食事する哲学者の問題では、箸がロックの役割を果たす。Haskell の軽量スレッド間でロックを取るには、MVar を使えばよい。以下のコードを走らせると、その内デッドロックする。

module Main where

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

numOfPhilosopher :: Int
numOfPhilosopher = 5

type Chopstick = MVar ()

newChopstick :: IO Chopstick
newChopstick = newMVar ()

getChopstick :: Chopstick -> IO ()
getChopstick = takeMVar

releaseChopstick :: Chopstick -> IO ()
releaseChopstick m = putMVar m ()

philosopher :: Int -> Chopstick -> Chopstick -> IO ()
philosopher n cs1 cs2 = forever $ do
    getChopstick cs1
    getChopstick cs2
    putStrLn $ "Philosopher " ++ show n ++ " is eating..."
    randomDelay
    releaseChopstick cs1
    releaseChopstick cs2
    putStrLn $ "Philosopher " ++ show n ++ " is thinking..."
    randomDelay

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

main :: IO ()
main = do
    let n = numOfPhilosopher
    css <- replicateM n newChopstick
    forM_ [1..n-1] $ \i ->
        forkIO $ philosopher i (css !! (i-1)) (css !! i)
    philosopher n (last css) (head css)

デッドロックしないコード

MVar を STM の TMVar へ、型を IO から STM へ、そして getChopstick と releaseChopstick を atomically で囲めば、デッドロックしないコードのできあがり。

module Main where

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

numOfPhilosopher :: Int
numOfPhilosopher = 5

type Chopstick = TMVar ()

newChopstick :: IO Chopstick
newChopstick = newTMVarIO ()

getChopstick :: Chopstick -> STM ()
getChopstick = takeTMVar

releaseChopstick :: Chopstick -> STM ()
releaseChopstick m = putTMVar m ()

philosopher :: Int -> Chopstick -> Chopstick -> IO ()
philosopher n cs1 cs2 = forever $ do
    atomically $ do
        getChopstick cs1
        getChopstick cs2
    putStrLn $ "Philosopher " ++ show n ++ " is eating..."
    randomDelay
    atomically $ do
        releaseChopstick cs1
        releaseChopstick cs2
    putStrLn $ "Philosopher " ++ show n ++ " is thinking..."
    randomDelay

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

main :: IO ()
main = do
    let n = numOfPhilosopher
    css <- replicateM n newChopstick
    forM_ [1..n-1] $ \i ->
        forkIO $ philosopher i (css !! (i-1)) (css !! i)
    philosopher n (last css) (head css)

備考

orElse が使いたかったが、簡潔さを追求したら IO が挟まって無理だった orz

あわせて読みたい：

• STM で解くサンタ問題