Some examples of Software Transactional Memory in Haskell

I've just finished teaching a course on Concurrent Programming. It's been fun. It's an increasingly important subject as software becomes more complex and processors get more cores. Most of the course has focused on lock-based shared memory synchronization. It's a tricky subject, you have to be very careful to avoid all the possibilities for deadlock. Fairness is also a tricky issue.

In the course I went through a couple of language constructs for synchronization, for example semaphores, monitors with condition variables and message passing. But at the end of the course I had time for one extra lecture and so I thought it would be nice to talk about transactional memory, which is the new hot language construct for simplifying concurrent programming. Sure, it can be implemented as a library as well, and that's how it's made in most languages, but that's a very fragile solution.

So, despite the fact that the languages used in the course are Java, JR and Erlang I chose to use Haskell in the lecture, simply because GHC provides better support for software transactional memory (STM) than any other system that I know of. I think it worked well, the kind of Haskell I used in the lectures is pretty imperative looking, simply because STM in Haskell uses monads, and so the code doesn't look to foreign even for someone not used to functional programming.

In this post I thought I'd share some snippets of code that I wrote for the lecture. They're all just standard examples in concurrent programming. Most of them look rather unimpressive but that's the whole point: programming with transactional memory is such a relief compared to fiddling with lock-based solutions.

This post is a literate Haskell file. Just copy-n-paste it into a file and you can try it out yourself.

> module STM where
>
> import Random
> import Control.Monad
> import Control.Concurrent
> import Control.Concurrent.STM

Let's start with something easy: binary semaphores. Or locks as they're also called. I've used the traditional names p and v here for acquiring and releasing the lock. They're really awful names though.

> type Semaphore = TVar Bool
>
> newSem :: Bool -> IO Semaphore
> newSem available = newTVarIO available
>
> p :: Semaphore -> STM ()
> p sem = do b <- readTVar sem
>            if b
>               then writeTVar sem False
>               else retry
>
> v :: Semaphore -> STM ()
> v sem = writeTVar sem True

The most impressive thing with the transactional memory implementation in GHC is in my opinion the retry combinator. It handles all conditional synchronization by complete magic. Sure, I happen to know how it works under the hood but the simplicity of the API is just marvellous. Whenever we have a condition that is not fulfilled, in the above code the condition is that the lock happens to be already taken, we just call retry. The runtime system will take care of waking up the process at the appropriate time. No messing around with condition variables or anything, like with monitors. It just couldn't be simpler. We'll see more of this in the examples that follow.

A slightly more interesting example: an unbounded buffer which processes can insert stuff into and then take out. It's written with clarity in mind, not efficiency. It's easy to make it more efficient but I didn't want to introduce more data types to the students so I used a naive list implementation. I leave an efficient implementation as an exercise to the reader.

> type Buffer a = TVar [a]
>
> newBuffer :: IO (Buffer a)
> newBuffer = newTVarIO []
> 
> put :: Buffer a -> a -> STM ()
> put buffer item = do ls <- readTVar buffer
>                      writeTVar buffer (ls ++ [item])
> 
> get :: Buffer a -> STM a
> get buffer = do ls <- readTVar buffer
>                 case ls of
>                   [] -> retry
>                   (item:rest) -> do writeTVar buffer rest
>                                     return item

Again the code is so clear and easy to understand that it makes you wonder how is could be any different. It should be said though that this implementation gives priority to processes writing to the buffer. If there is a single process writing to the buffer he can make an arbitrary amount of readers retry. A lock-based implementation provides mutual exclusion so only one process at a time has access to the buffer. In such an implementation processes get access in the same order as they requested it so writers do not have priority over readers. But that implementation of course has all the usual problems that a lock-based implementation has.

One standard pattern that I used a lot in the course was resource allocation. I used a distilled version where there is a counter keeping track of the amount of resources available. Processes may ask for an arbitrary amount of resources and block if they're not available. This interface has the advantage that it's resource agnostic and can be implemented in a language like Java. I'm sure there are nicer ways to do it in Haskell, depending on the resource.

> type Resource = TVar Int
> 
> acquire :: Resource -> Int -> STM ()
> acquire res nr = do n <- readTVar res
>                     if n < nr
>                        then retry
>                        else writeTVar res (n - nr)
>                             
> release :: Resource -> Int -> STM ()
> release res nr = do n <- readTVar res
>                     writeTVar res (n + nr)

As a final example I will give an implementation of the dining philosophers. It's one of the classic problems in concurrent programming and so it's interesting to see how STM performs.

To make this program interesting we have to output what the philosophers are doing so that we can verify that the simulation is correct. But the standard I/O primitives in Haskell are not thread safe so we have to take a bit of care when writing stuff to standard out. The way I've solved it is to have a buffer which all the philosopher processes writes to and then I have a separate thread which reads from the buffer and writes to the screen. That way only one process does the outputting and there is no risk of weird output.

I'm not going to go through the exact formulation of the dining philosophers problem. If you're unsure how it goes I suggest you read the wikipedia article on it. I've chosen to implement the forks as the binary semaphores that we defined above.

> simulation n = do forks <- replicateM n (newSem True)
>                   outputBuffer <- newBuffer
>                   for [0..n-1] $ \i -> 
>                     forkIO (philosopher i outputBuffer
>                             (forks!!i) 
>                             (forks!!((i+1)`mod`n)))
>                   output outputBuffer
>
> output buffer = 
>     do str <- atomically $ get buffer
>        putStrLn str
>        output buffer
>
> for = flip mapM_

This first bit of code just sets everything up for the simulation. The function simulation take the number of philosophers as an argument. Then it creates the required number of forks, the output buffer and spawns off all the philosopher processes which are given their corresponding forks. Finally the main thread goes into a loop which reads of the strings from the output buffer and prints them.

> philosopher :: Int -> Buffer String -> Semaphore -> Semaphore -> IO ()
> philosopher n out fork1 fork2 = 
>     do atomically $ put out ("Philosopher " ++ show n ++ " is thinking.")
>        randomDelay
>
>        atomically $ do
>          p fork1
>          p fork2
>
>        atomically $ put out ("Philosopher " ++ show n ++ " is eating.")
>        randomDelay
>
>        atomically $ do
>          v fork1
>          v fork2
>
>        philosopher n out fork1 fork2
>
> randomDelay = do r <- randomRIO (100000,500000)
>                  threadDelay r

Again, this implementation is so simple that you wonder what the problem was in the first place. The power comes from being able to compose several transactions together sequentially and perform them atomically.

Note that the philosophers execute in the IO monad and only invoke the transactional memory bit when it has to do synchronization. This is the typical usage of transactional memory, something we didn't see with the earlier examples.

There's one thing that's not so nice with GHC's implementation of STM though. You can see it for yourself if you change the call to randomDelay to a call to threadDelay with a fixed time. What will happen is that one of the philosophers will starve. I will not say more about that here though, it's the topic of another blog post.

That's all for this post. I hope you find the examples useful.

Fun Functions: Flatten

This post is going to be about a function which may not seem like much, it takes a tree and returns the elements of the tree in a list the way an inorder traversal would visit them. While this is not an uncommon task in programming it is so mundane that it hardly deserves a blog post on its own. So why am I writing this? The thing that have captured me is a particular implementation of this function. Let us first set the scene. This blog post is a literate Haskell file and you should be able so save it to a file and run it yourself.

> module Flatten where
> import Test.QuickCheck
> data Tree a = Node (Tree a) a (Tree a) | Leaf deriving Show

So we have a data type for trees, it's the standard one. Nothing surprising here. The scene is set. How would we go about implementing flatten then? There are in fact a whole number of ways to implement it and I'm going to show several of them. The last version will be my favorite one and after having seen all the other versions I hope you will appreciate it as I do. Let us then start with something rather naive. A straightforward recursive function which turns a tree into a list:

> flatten1 :: Tree a -> [a]
> flatten1 Leaf           = []
> flatten1 (Node t1 a t2) = flatten1 t1 ++ [a] ++ flatten1 t2

That's very concise and easy to understand. But this solution has a slight problem. It takes quadratic time. This is due to the fact that ++ take linear time in it's left argument. It is a well known problem with many solutions. The standard solution, due to John Hughes, is to represent lists as functions from lists to lists. This way we get constant time concatenation. Incidentally, some people seem to think that this version is fine. It is used on the type level by alpheccar in his blog. Implementing lists the Hughes way gives us our second variation of flatten.

> flatten2 :: Tree a -> [a]
> flatten2 tree = help2 tree []
> 
> help2 :: Tree a -> [a] -> [a]
> help2 Leaf           = id
> help2 (Node t1 a t2) = help2 t1 . (a :) . help2 t2

Hmmmm. I don't know what you think of this version but I don't like it. For two reasons. It uses higher order programming when it isn't necessary, and that just obfuscates things. Secondly, it needs a helper function. It would be nice if we could do without that. Let's start by tackling the first problem of higher order programming. One way to remove the higher orderness is to give the function help2 an extra argument (called eta expansion, if that means anything to you). This gives us the following version.

> flatten3 :: Tree a -> [a]
> flatten3 tree = help3 tree []
> 
> help3 :: Tree a -> [a] -> [a]
> help3 Leaf           rest = rest
> help3 (Node t1 a t2) rest = help3 t1 (a : help3 t2 rest)

I call the extra argument rest because it contains the rest of the elements that we should put in the list. This solution still uses a helper function which is a bit of a nuisance but unfortunately I don't know an easy way to remove it. Instead I'm going to present another way to think about flattening that will take us down another road. How would you go about implementing an inorder traversal with a while loop instead of recursion? The solution would be to use a stack to remember the parts of the tree that we haven't visited yet. We can use the same idea to write a new version of flatten, using a list as the stack. The top of the stack will be the part of the tree that we are visiting at the moment. We will need a little trick to remember when we have visited a subtree and that is to simply remove it from its parent. The final code looks like this.

> flatten4 :: Tree a -> [a]
> flatten4 tree = help4 [tree]
>
> help4 :: [Tree a] -> [a]
> help4 [] = []
> help4 (Leaf : ts) = help4 ts
> help4 (Node Leaf a t : ts) = a : help4 (t : ts)
> help4 (Node t1 a t2 : ts) = help4 (t1 : Node Leaf a t2 : ts)

This version is pretty clever. It takes apart the tree and spreads it out into the list until there is nothing left of the tree. But one might argue that this version is too clever. It is certainly not easy to understand from the code. Plus it uses a helper function, something that we have been trying to get away from. The final version that I will show builds upon the idea that we can represent the list of trees from our previous version as simply a tree. We are going to use the input tree as the stack and modify it as we go along. It goes like this.

> flatten5 :: Tree a -> [a]
> flatten5 Leaf = []
> flatten5 (Node Leaf a t) = a : flatten5 t
> flatten5 (Node (Node t1 a t2) b t3) = flatten5 (Node t1 a (Node t2 b t3))

What happens in the third equation is that the tree is restructured so that it becomes a linear structure, just like a list. It is then simple to read off the element in the second equation. This is my favorite version. It's short, without helper functions and no higher order stuff. Plus it is efficient. Now, you might complain that it does more allocations that some of the previous versions. Indeed we have to allocate new trees in the third case. But note that that case is tail recursive. That means that it doesn't use any stack. It is possible to implement this version of the function so that it doesn't any more space than any of the other versions above. The control stack is encoded into the tree. One additional thing about this version is that it's termination is not entirely obvious. This function will fool several termination checkers that I know of. In particular, in the third equation the argument tree in recursive call is not smaller than the input tree. This is a criterion that many termination checker use. To understand that the function terminates you must instead see that it is the left subtree of the input that gets smaller together with the fact that trees are finite. To me this is an extra bonus. You might think otherwise. Finally, I have some code to test that all the version I've given above are equal.

> instance Arbitrary a => Arbitrary (Tree a) where
>   arbitrary = sized arbTree
>    where arbTree 0 = return Leaf
>          arbTree n | n>0 = frequency $
>                 [(1, return Leaf)
>                 ,(4, do elem <- arbitrary
>                         t1   <- arbTree (n `div` 2)
>                         t2   <- arbTree (n `div` 2)
>                         return (Node t1 elem t2))]
> prop_flatten2 t = flatten1 t == flatten2 (t ::Tree Int)
> prop_flatten3 t = flatten1 t == flatten3 (t ::Tree Int)
> prop_flatten4 t = flatten1 t == flatten4 (t ::Tree Int)
> prop_flatten5 t = flatten1 t == flatten5 (t ::Tree Int)
> runTests = mapM_ quickCheck [prop_flatten2,prop_flatten3,
>                              prop_flatten4,prop_flatten5]
> 

Learning Monads in 1996

Given the plethora of monad tutorials these days it's hard to imagine how anybody could have learned about this concept during the 90's. I learned most of what I know about monads in 1996, back in the days when even researchers had a hard time understanding the list monad. This post will not be another monad tutorial. I'm simply going to explain how I managed to become friendly with monads in a time where monad tutorials where very scarce. So, why did I start looking into monads in the first place? In 1995 I started my undergraduate studies at Chalmers and the first language we were taught was Gofer, a now extinct dialect of Haskell. When the time came for teaching us I/O they didn't show us the monadic way of doing things. Apparently our teacher (who by the way was not a functional programmer, a strange fact considering that Chalmers abound with functional programmers) thought that the concept of monads was too scary and complicated and taught us continuation I/O, something which I experienced as painfully horrible and utterly confusing. But some of us students had heard about monads and how they were supposed to be they way of the future when it came to I/O and other things. They sounded really cool, and hey, they couldn't possibly be worse than continuation I/O right? So I set my mind to learning monads. I tried to read everything that was available on the subject which wasn't much at the time. There were two papers which I spent a considerable time with: "The essence of functional programming" and "Monads for functional programming" by Phil Wadler. I implemented every single bit of code in those papers, tore the code to pieces and put it back again. I started implementing monadic parser libraries based on the paper "Monadic parser combinators" by Hutton and Meijer. Trying out different implementations and combinators I wrote variation after variation of these libraries. I don't know how many of parser libraries I implemented in the end. I've lost count. Slowly I was starting to grasp monads as I played around with them. After some time I was even able to digest and understand the paper "Monad Transformers and Modular Interpreters" but it certainly didn't happen the first time I read it. What finally pushed me over the edge was when a friend asked me how to combine different monads. I didn't know the answer and for some reason it kind of bugged me that I couldn't answer his question. But I had a vague recollection of ideas in the above paper. Determined to understand this, I sat down and started to hack on monad transformers and didn't finish until I finally had a rudimentary understanding of them, several hours later. Monadic I/O turned out to be a breeze to learn thanks to the nice "Monadic I/O in Haskell 1.3" by Kevin Hammond and Andrew Gordon. And there you have it. The way I learned about monads. No magic, just hard work. I'm a slow learner and you can probably get comfortable with monads much faster than I. But I don't think you'll find any method which is significantly different from mine. What makes me say that? Why are monads such a difficult concept to learn? The conclusion I've come to is that the difficulty lie in the fact that it's an abstraction. Abstract things are simply hard, especially for people who have little experience with abstractions before. As an example take an abstraction like the concept of a group. What is a group? It's a set, call it G, and a binary operator on G which is associative and has inverses and an identity element. For anyone used to abstractions this is a perfectly fine definition. But not so for your average man on the street, or even programmer. They will react something like this: "Ok, I understand the definition. But what *is* a group? I mean, in *reality*?" I remember having similar thoughts myself. The fact that a group is not a concrete thing is a great confusion. In my experience this only settles after the person has gained some experience with lots of examples of what a group is, and a few examples of things that fail to be a group. By then most people will have gotten pretty comfortable with the concept. It's the same thing with monads. They're an abstract concept which will take time to digest. And this digestion is best done by playing around with various examples of monads and occasionally meet examples of data types which are not monads and for what reason they fail. I don't think there are any shortcuts to learning abstract concepts. But I think that one can become better at it and it certainly helps to have a good tutorial when learning a subject, such as monads.