In the last article, I discussed MVar and Chan for developing concurrent programs in Haskell. In this article, I would like to talk about an alternative way of achieving concurrency: semaphores.

Binary Semaphores

A semaphore works like a counter that can be either incremented or decremented atomically, and a binary semaphore is a semaphore that can only count up to 1. It can be used like a mutex lock to allow only one thread to run at a time.

import Control.Concurrent
 
hello :: QSem -> IO ()
hello qSem = do
  tid <- myThreadId
  waitQSem qSem
  print $! "Hello! "++show tid
  signalQSem qSem
 
 
main :: IO ()
main = do
  qSem <- newQSem 0
  forkIO $ hello qSem
  signalQSem qSem

The binary semaphore can be implemented using QSem. A new QSem can be created with newQSem with either 0 or 1, and the semaphore can be incremented by signalQSem or decremented by waitQSem.

Counting Semaphores

Counting semaphores are semaphores without the upper bound of 1, and they can be a replacement for Chan. Unlike Chan, semaphores do not require a loop to wait for the semaphore to be incremented n times. Counting semaphores are implemented as QSemN, where they can be initialized with newQSemN with any positive value, incremented by signalQSemN, or decremented by waitQSemN. Using QSem and QSemN, we can refactor the concurrent program that prints out 10 thread IDs as follows:

getGreeting :: IO String
getGreeting = do
  tid <- myThreadId
  let greeting = "Hello from" ++ show tid
  return $! greeting
 
hello :: QSem -> QSemN -> IO ()
hello mutexLock endFlags = do
  greeting <- getGreeting
  waitQSem mutexLock
  putStrLn greeting
  signalQSem mutexLock
  signalQSemN endFlags 1
 
main :: IO()
main = do
  hSetBuffering stdout NoBuffering
  mutexLock <- newQSem 0
  endFlags <- newQSemN 0
  let n = 10
  mapM_ (const $ forkIO $ hello mutexLock endFlags) [1..n]
  signalQSem mutexLock
  waitQSemN endFlags n

Deadlocks

MVar, Chan, and semaphores are quite useful for writing concurrent programs, but there is a critical issue that affects all of them: deadlocks. Deadlocks occur when all of the threads are waiting forever for a mutex to be released, a channel to be written to, or a semaphore to receive a signal, when there is no thread capable of doing any of the above. The following is the simplest example of a deadlock:

hello :: QSem -> IO ()
hello qSem = do
  tid <- myThreadId
  waitQSem qSem
  print $! "Hello! "++show tid
  signalQSem qSem
 
 
main :: IO ()
main = do
  qSem <- newQSem 0
  let n = 10
  mapM_ (const $ forkIO $ hello qSem) [1..n]

The above code creates 10 threads that wait for the QSem to be incremented, but no thread is trying to increment the QSem, causing all the threads to freeze. It is easy to spot an obvious deadlock like the one above, but deadlocks can occur implicitly as well. The following is an example of such a deadlock:

hello1 :: MVar () -> MVar () -> IO ()
hello1 mVar1 mVar2 = do
  tid <- myThreadId
  takeMVar mVar1
  takeMVar mVar2
  print $! "Hello 1! "++show tid
  putMVar mVar1 ()
  putMVar mVar2 ()
 
hello2 :: MVar () -> MVar () -> IO ()
hello2 mVar1 mVar2 = do
  tid <- myThreadId
  takeMVar mVar2
  takeMVar mVar1
  print $! "Hello 2! "++show tid
  putMVar mVar1 ()
  putMVar mVar2 ()
 
 
main :: IO ()
main = do
  mVar1 <- newEmptyMVar
  mVar2 <- newEmptyMVar
  let n = 5
  mapM_ (const $ forkIO $ hello1 mVar1 mVar2) [1..n]
  mapM_ (const $ forkIO $ hello2 mVar1 mVar2) [1..n]
  putMVar mVar1 ()
  putMVar mVar2 ()

The hello1 and hello2 functions are almost identical, but they differ in the order of taking MVar. What sometimes happens in a situation like the one above is that one thread of hello1 locks mVar1 and another thread of hello2 locks mVar2 before they lock the other MVar. This causes both threads to freeze, and other threads to also freeze. While this may seem like an unlikely mistake in a small chunk of code like the above, it is a real issue that can frequently occur in a larger codebase.

Therefore, we need to be very careful when using mutexes, channels, and semaphores, or we need an alternative way of achieving concurrency without the problem of deadlocks, which I will introduce in the next article.

Exercises

This is an exercise section where you can test your understanding of the material introduced in the article. I highly recommend solving these questions by yourself after reading the main part of the article. You can click on each question to see its answer.

Resources

• Philipp, Hagenlocher. 2020. Haskell for Imperative Programmers #29 - Semaphores (QSem, QSemN). YouTube.