In the implementation of MonadConc for IO, as well as the implementation of MonadSTM for STM, most if not all functions map directly to their IO and STM counterparts from base and stm. Hence, if we can convince the compiler to emit code not using the type class dictionary when using testable functions (i.e., functions using MonadConc and MonadSTM) in environments where testability is not needed (i.e., when used in IO and STM), there should be no performance impact.

Since this is a Literate Haskell file, some boilerplate before we continue (see this article for more information on how this works):

{- cabal:
build-depends:
  , base ^>=4.17
  , concurrency ^>=1.11.0.2
  , stm ^>=2.5.1.0
  , tasty ^>=1.4.3
  , tasty-bench ^>=0.3.3
  , tasty-inspection-testing ^>=0.2
default-language: Haskell2010
build-tool-depends: markdown-unlit:markdown-unlit
ghc-options:
  -pgmL markdown-unlit
  -rtsopts=all "-with-rtsopts=-T -A32m"
  -fproc-alignment=64
  -ddump-simpl
  -dsuppress-idinfo
  -dsuppress-coercions
  -dsuppress-type-applications
  -dsuppress-uniques
  -dsuppress-module-prefixes
-}

{-# LANGUAGE TemplateHaskell #-}

module Main (
  main,
  benchSTM,
  benchConcurrencyNoInline,
  benchConcurrency,
  benchConcurrencySpecialized
  ) where

import qualified Control.Concurrent.STM as STM
import qualified Control.Concurrent.Classy.STM as C
import qualified Control.Monad.Conc.Class as C
import Test.Tasty (TestTree, testGroup, withResource)
import Test.Tasty.Bench (Benchmark, bench, bcompare, bgroup, defaultMain, nfIO)
import Test.Tasty.Inspection (inspectTest, hasNoTypeClasses, (==-))

Benchmark Baseline

To start, let’s measure the baseline performance of a very simple STM transaction which takes three TVar Ints, reads the contents of the first two, puts their sum in the third, then reads the third and returns the value:

benchSTM :: STM.TVar Int -> STM.TVar Int -> STM.TVar Int -> STM.STM Int
benchSTM v1 v2 v3 = do
  v1' <- STM.readTVar v1
  v2' <- STM.readTVar v2
  STM.writeTVar v3 $! v1' + v2'
  STM.readTVar v3

benchConcurrencyNoInline ::
  C.MonadSTM stm =>
  C.TVar stm Int ->
  C.TVar stm Int ->
  C.TVar stm Int ->
  stm Int
benchConcurrencyNoInline v1 v2 v3 = do
  v1' <- C.readTVar v1
  v2' <- C.readTVar v2
  C.writeTVar v3 $! v1' + v2'
  C.readTVar v3
{-# NOINLINE benchConcurrencyNoInline #-}

withVars:: (IO (STM.TVar Int, STM.TVar Int, STM.TVar Int) -> TestTree) -> TestTree
withVars = withResource mkTVars (const $ pure ())
  where
    mkTVars = (,,) <$> STM.newTVarIO 1
                   <*> STM.newTVarIO 2
                   <*> STM.newTVarIO 0

benchSTMvsBenchConcurrencyNoInline :: Benchmark
benchSTMvsBenchConcurrencyNoInline = withVars $ \getVars -> testGroup "baseline" [
    bench "STM" $ nfIO $ getVars >>= \(v1, v2, v3) ->
      STM.atomically $ benchSTM v1 v2 v3,
    bcompare "STM" $
      bench "ConcurrencyNoInline" $ nfIO $ getVars >>= \(v1, v2, v3) ->
        C.atomically $ benchConcurrencyNoInline v1 v2 v3
  ]

Running this benchmark yields not-so-stellar results:

  baseline
    STM:                 OK (0.40s)
      45.4 ns ± 4.2 ns,  63 B  allocated,   0 B  copied,  34 MB peak memory
    ConcurrencyNoInline: OK (0.27s)
      126  ns ± 5.5 ns, 505 B  allocated,   0 B  copied,  34 MB peak memory, 2.78x

Automatic Specialization

The NOINLINE pragma on benchConcurrencyNoInline prohibits GHC to inline the code (in the benchmark), otherwise specialization could trigger.

If we create a version of the code without the INLINE pragma and benchmark it again, it appears the code performs roughly the same as the native STM version:

benchConcurrency ::
  C.MonadSTM stm =>
  C.TVar stm Int ->
  C.TVar stm Int ->
  C.TVar stm Int ->
  stm Int
benchConcurrency v1 v2 v3 = do
  v1' <- C.readTVar v1
  v2' <- C.readTVar v2
  C.writeTVar v3 $! v1' + v2'
  C.readTVar v3

benchSTMvsBenchConcurrency :: Benchmark
benchSTMvsBenchConcurrency = withVars $ \getVars -> testGroup "plain" [
    bcompare "STM" $
      bench "Concurrency" $ nfIO $ getVars >>= \(v1, v2, v3) ->
        C.atomically $ benchConcurrency v1 v2 v3
  ]

yields

  plain
    Concurrency:         OK (0.39s)
      45.8 ns ± 3.4 ns,  63 B  allocated,   0 B  copied,  35 MB peak memory, 1.01x

Why does this happen, and can we be certain this is not a fluke?

Inspecting Core

To investigate, we can pass some options to GHC so it prints the Core it generates. Core is a language somewhat like a very simplified version of Haskell, without type classes (which are desugared into dictionaries at this point), that can then be compiled into even more low-level languages before binary code is generated. Here are the important bits:

benchSTM1
  :: TVar Int
     -> TVar Int
     -> TVar Int
     -> State# RealWorld
     -> (# State# RealWorld, Int #)
benchSTM1
  = \ (v1 :: TVar Int)
      (v2 :: TVar Int)
      (v3 :: TVar Int)
      (s :: State# RealWorld) ->
      case v1 of { TVar tvar# ->
      case readTVar# tvar# s of { (# ipv, ipv1 #) ->
      case v2 of { TVar tvar#1 ->
      case readTVar# tvar#1 ipv of { (# ipv2, ipv3 #) ->
      case ipv1 of { I# x ->
      case ipv3 of { I# y ->
      case v3 of { TVar tvar#2 ->
      case writeTVar# tvar#2 (I# (+# x y)) ipv2 of s2# { __DEFAULT ->
      readTVar# tvar#2 s2#
      }
      }
      }
      }
      }
      }
      }
      }

benchSTM :: TVar Int -> TVar Int -> TVar Int -> STM Int
benchSTM
  = benchSTM1
    `cast` <Co:15> :: (TVar Int
                       -> TVar Int
                       -> TVar Int
                       -> State# RealWorld
                       -> (# State# RealWorld, Int #))
                      ~R# (TVar Int -> TVar Int -> TVar Int -> STM Int)

With a bit of imagination, we can see benchSTM1 resembles our original benchSTM code, in a state monad over State# RealWorld. Keep in mind TVar is a newtype constructor over the compiler-internal representation of a TVar (which is TVar# RealWorld a), and readTVar# and friends are alike readTVar, but for the internal TVar# type.

benchSTM is benchSTM1 casted to plain STM (which is, like IO, a newtype of State# RealWorld -> (# State# RealWorld, a #)).

Here’s benchConcurrencyNoInline:

benchConcurrencyNoInline
  :: forall (stm :: * -> *).
     MonadSTM stm =>
     TVar stm Int -> TVar stm Int -> TVar stm Int -> stm Int
benchConcurrencyNoInline
  = \ (@(stm :: * -> *)) ($dMonadSTM :: MonadSTM stm) ->
      let {
        $dMonad :: MonadPlus stm
        $dMonad = $p2MonadSTM $dMonadSTM } in
      let {
        $dMonad1 :: Monad stm
        $dMonad1 = $p2MonadPlus $dMonad } in
      \ (v1 :: TVar stm Int) (v2 :: TVar stm Int) (v3 :: TVar stm Int) ->
        let {
          lvl15 :: stm Int
          lvl15 = readTVar $dMonadSTM v2 } in
        let {
          lvl16 :: stm Int
          lvl16 = readTVar $dMonadSTM v3 } in
        >>=
          $dMonad1
          (readTVar $dMonadSTM v1)
          (\ (v1' :: Int) ->
             >>=
               $dMonad1
               lvl15
               (\ (v2' :: Int) ->
                  >>
                    $dMonad1
                    (case v1' of { I# x ->
                     case v2' of { I# y -> writeTVar $dMonadSTM v3 (I# (+# x y)) }
                     })
                    lvl16))

Here, the MonadSTM dictionary is passed along (and then unpacked to retrieve the MonadPlus and Monad instances as well), and every call to, e.g., readTVar becomes a field lookup from the dictionary (readTVar $dMonadSTM is like a regular field lookup in a data record), hence an indirect call. Also, the monadic binds (>>= and >>) can’t be expanded as is the case in benchSTM. It seems pretty clear why benchConcurrencyNoInline performs about 2.78x slower than benchSTM!

Last but not least, the code GHC generates for benchConcurrency:

benchConcurrency
  :: forall (stm :: * -> *).
     MonadSTM stm =>
     TVar stm Int -> TVar stm Int -> TVar stm Int -> stm Int
benchConcurrency
  = \ (@(stm :: * -> *)) ($dMonadSTM :: MonadSTM stm) ->
      let {
        $dMonad :: MonadPlus stm
        $dMonad = $p2MonadSTM $dMonadSTM } in
      let {
        $dMonad1 :: Monad stm
        $dMonad1 = $p2MonadPlus $dMonad } in
      \ (v1 :: TVar stm Int) (v2 :: TVar stm Int) (v3 :: TVar stm Int) ->
        let {
          lvl15 :: stm Int
          lvl15 = readTVar $dMonadSTM v2 } in
        let {
          lvl16 :: stm Int
          lvl16 = readTVar $dMonadSTM v3 } in
        >>=
          $dMonad1
          (readTVar $dMonadSTM v1)
          (\ (v1' :: Int) ->
             >>=
               $dMonad1
               lvl15
               (\ (v2' :: Int) ->
                  >>
                    $dMonad1
                    (case v1' of { I# x ->
                     case v2' of { I# y -> writeTVar $dMonadSTM v3 (I# (+# x y)) }
                     })
                    lvl16))

This looks… suspiciously similar to the benchConcurrencyNoInline code. But when running the benchmark, the performance of the regular version was aligned with the benchSTM code. What’s going on?

It turns out GHC spotted an opportunity for specialization, and performed the following two steps:

• It created a specialized version of the function:

benchConcurrency1
  :: TVar STM Int
     -> TVar STM Int
     -> TVar STM Int
     -> State# RealWorld
     -> (# State# RealWorld, Int #)
benchConcurrency1
  = \ (v1 :: TVar STM Int)
      (v2 :: TVar STM Int)
      (v3 :: TVar STM Int)
      (eta :: State# RealWorld) ->
      case v1 `cast` <Co:3> :: TVar STM Int ~R# TVar Int of
      { TVar tvar# ->
      case readTVar# tvar# eta of { (# ipv, ipv1 #) ->
      case v2 `cast` <Co:3> :: TVar STM Int ~R# TVar Int of
      { TVar tvar#1 ->
      case readTVar# tvar#1 ipv of { (# ipv2, ipv3 #) ->
      case ipv1 of { I# x ->
      case ipv3 of { I# y ->
      case v3 `cast` <Co:3> :: TVar STM Int ~R# TVar Int of
      { TVar tvar#2 ->
      case writeTVar# tvar#2 (I# (+# x y)) ipv2 of s2# { __DEFAULT ->
      readTVar# tvar#2 s2#
      }
      }
      }
      }
      }
      }
      }
      }

Note this is, modulo some different but related cast invocations (which have no runtime impact) the very same as benchSTM1. Indeed, this is a specialized version of benchConcurrency for TVar STM Int -> TVar STM Int -> TVar STM Int -> STM Int, i.e., when using benchConcurrency in the regular STM monad.

• It created a rule to rewrite calls to benchConcurrency, when used in the STM monad, to benchConcurrency1:

"SPEC benchConcurrency @STM"
    forall ($dMonadSTM :: MonadSTM STM).
      benchConcurrency $dMonadSTM
      = benchConcurrency1
        `cast` <Co:18> :: (TVar STM Int
                           -> TVar STM Int
                           -> TVar STM Int
                           -> State# RealWorld
                           -> (# State# RealWorld, Int #))
                          ~R# (TVar STM Int -> TVar STM Int -> TVar STM Int -> STM Int)

Note the $dMonadSTM dictionary isn’t used on the right hand side of the rewrite rule, so we can be certain no indirections through the MonadSTM dictionary can be used in benchConcurrency1.

When inspecting the actual benchmark code, we can see a call to benchConcurrency1 is used instead of a call to benchConcurrency, and hence, we get the very same performance as the benchSTM version:

{ (# ipv, ipv1 #) ->
case ipv1 of { (v1, v2, v3) ->
case atomically#
       (benchConcurrency1
          (v1 `cast` <Co:4> :: TVar Int ~R# TVar STM Int)
          (v2 `cast` <Co:4> :: TVar Int ~R# TVar STM Int)
          (v3 `cast` <Co:4> :: TVar Int ~R# TVar STM Int))
       ipv

Explicit Specialization

Great, GHC is able to specialize MonadSTM code to the equivalent STM code when it spots an opportunity to do so. However, this only works within a single module: if benchConcurrency were defined in one module, and used from another to benchmark it, the implementation of benchConcurrency is no longer visible to GHC, except if it decided the function is small enough to be inlineable, or we told it (with the INLINE pragma) to do so. Many STM functions are relatively large though, so we don’t necessarily want to inline them. What to do?

As a library author, we can force GHC to create specialized versions of some code for us, and generate the according rewrite rule as well, as if it decided to do so by itself within a single module. Let’s give this a try:

benchConcurrencySpecialized ::
  C.MonadSTM stm =>
  C.TVar stm Int ->
  C.TVar stm Int ->
  C.TVar stm Int ->
  stm Int
benchConcurrencySpecialized v1 v2 v3 = do
  v1' <- C.readTVar v1
  v2' <- C.readTVar v2
  C.writeTVar v3 $! v1' + v2'
  C.readTVar v3
{-# SPECIALIZE benchConcurrencySpecialized ::
      STM.TVar Int -> STM.TVar Int -> STM.TVar Int -> STM.STM Int #-}

benchSTMvsBenchConcurrencySpecialized :: Benchmark
benchSTMvsBenchConcurrencySpecialized = withVars $ \getVars -> testGroup "specialized" [
    bcompare "STM" $
      bench "ConcurrencySpecialized" $ nfIO $ getVars >>= \(v1, v2, v3) ->
        C.atomically $ benchConcurrencySpecialized v1 v2 v3
  ]

Note the use of the SPECIALIZE pragma above. Running this gives

  specialized
    ConcurrencySpecialized: OK (0.20s)
      47.9 ns ± 4.4 ns,  63 B  allocated,   0 B  copied,  35 MB peak memory, 1.03x

Furthermore, the following Core is generated:

benchConcurrencySpecialized
  :: forall (stm :: * -> *).
     MonadSTM stm =>
     TVar stm Int -> TVar stm Int -> TVar stm Int -> stm Int
benchConcurrencySpecialized
  = \ (@(stm :: * -> *)) ($dMonadSTM :: MonadSTM stm) ->
      let {
        $dMonad :: MonadPlus stm
        $dMonad = $p2MonadSTM $dMonadSTM } in
      let {
        $dMonad1 :: Monad stm
        $dMonad1 = $p2MonadPlus $dMonad } in
      \ (v1 :: TVar stm Int) (v2 :: TVar stm Int) (v3 :: TVar stm Int) ->
        let {
          lvl19 :: stm Int
          lvl19 = readTVar $dMonadSTM v2 } in
        let {
          lvl20 :: stm Int
          lvl20 = readTVar $dMonadSTM v3 } in
        >>=
          $dMonad1
          (readTVar $dMonadSTM v1)
          (\ (v1' :: Int) ->
             >>=
               $dMonad1
               lvl19
               (\ (v2' :: Int) ->
                  >>
                    $dMonad1
                    (case v1' of { I# x ->
                     case v2' of { I# y -> writeTVar $dMonadSTM v3 (I# (+# x y)) }
                     })
                    lvl20))

"SPEC benchConcurrencySpecialized"
    forall ($dMonadSTM :: MonadSTM STM).
      benchConcurrencySpecialized $dMonadSTM
      = benchConcurrency1
        `cast` <Co:18> :: (TVar STM Int
                           -> TVar STM Int
                           -> TVar STM Int
                           -> State# RealWorld
                           -> (# State# RealWorld, Int #))
                          ~R# (TVar STM Int -> TVar STM Int -> TVar STM Int -> STM Int)

The compiler detected the specialized version of benchConcurrencySpecialized for STM is the very same as the specialized version it already created for benchConcurrency, so benchConcurrency1 gets simply reused.

With the SPECIALIZE pragma in place, we can write and test code using MonadSTM, whilst at the same time guaranteeing that users of the library using plain STM code won’t incur any performance hit.

Testing

We can even go one step further, and ensure MonadSTM usage is completely erased: in a test using the inspection-testing library. Even more, we can check whether two versions of a function using our library function are (after inlining) the same:

stmVersion :: IO ()
stmVersion = do
  v <- STM.newTVarIO 0
  _ <- STM.atomically $ benchSTM v v v
  pure ()

concurrencyVersion :: IO ()
concurrencyVersion = do
  v <- STM.newTVarIO 0
  _ <- STM.atomically $ benchConcurrencySpecialized v v v
  pure ()

testMonadSTMErased :: TestTree
testMonadSTMErased = $(inspectTest $ hasNoTypeClasses 'concurrencyVersion)

testFunctionsEqual :: TestTree
testFunctionsEqual = $(inspectTest $ 'concurrencyVersion ==- 'stmVersion)

  concurrencyVersion does not contain dictionary values: OK
  concurrencyVersion ==- stmVersion:                     OK

Success!

Conclusion

This article showns how, with liberal use of SPECIALIZE pragmas in library code, it’s possible to eliminate the overhead of MonadConc and MonadSTM when library functions are used in the regular IO and STM monads. Hence, let this be a call to library authors to write their code using MonadConc and MonadSTM such that consumers of the library can still write DejaFu tests for code using data structures and functions defined in it!

Wrapping Up

To wrap up, run all benchmarks and tests:

main :: IO ()
main = defaultMain [
  benchSTMvsBenchConcurrencyNoInline,
  benchSTMvsBenchConcurrency,
  benchSTMvsBenchConcurrencySpecialized,
  testMonadSTMErased,
  testFunctionsEqual
  ]

One way to tackle this is keeping the code in some source file(s), ensure these compile, and copy-paste snippets into the Markdown source of an article. This works, but copy-paste leaves room for error, and updating source-code while writing the article, then making sure all snippets are updated correctly, is definitely error-prone.

Wouldn’t it be nice if the article file itself would be executable (or, at least, checked by the compiler)? Luckily this is possible, without all too much hassle! Given a working Jekyll installation, here’s what we want:

• A way to turn an article, including code blocks, into input the compiler can work with.
• A way to run the article file, or load it in a REPL, including any dependencies the code relies on.
• A way for Jekyll to include such articles in the rendered website.

Compiling Markdown

The GHC Haskell compiler has built-in support for Literate Haskell, which allows to interleave code blocks with text. The native Literate Haskell support doesn’t know about Markdown formatting, but with some flags, GHC can be instructed to use some custom preprocessor which knows how to extract code from some literate source file.

The markdown-unlit package does exactly this for Markdown-formatted files: it extracts all Haskell code blocks and passes these to the compiler. So Markdown-formatted input like

Here's how to print the string "Hello, world" on the console:

```haskell
printHelloWorld :: IO ()
printHelloWorld = putStrLn "Hello, world"
```

Simple!

becomes

printHelloWorld :: IO ()
printHelloWorld = putStrLn "Hello, world"

For GHC to use the markdown-unlit preprocessor, the -pgmL option must be used, and the source file must have the .lhs file extension.

Aside: Testing README.md

Next to running Markdown articles, markdown-unlit can be used to test your project’s README.md, as I do in the landlock package. See this example for more information!

Running Articles

Now we know how to extract code blocks from article source files for the compiler to process them, we need a way to invoke the compiler (or launch it in REPL mode) with some source file. Of course the ghc binary can be invoked as-is, passing the necessary -pgmL option and any others, but this has several drawbacks, especially when the code in the article depends on some other packages:

• markdown-unlit must be pre-installed
• We must not forget the -pgmL option, including the path to markdown-unlit unless it’s installed in $PATH
• Any dependencies must be installed in a way for GHC to find them
• Dependencies may require -package ... or other options to be passed to GHC

In the Haskell ecosystem, the cabal tool is used to install dependencies, invoke the compiler with the right options to find these dependencies, etc. In regular Haskell packages, a Cabal project description file (packagename.cabal) contains all information needed for cabal to do its job. A Jekyll article Markdown source file doesn’t come with a project description file, so how can the cabal-install functionality be reused? I recently found out cabal nowadays has a scripting mode: it can read metadata, enclosed in a comment block, from a source file, and use it accordingly. So, including the following in the Markdown source of an article will instruct cabal to provide all dependencies (none but base for this article), ensure markdown-unlit is available, and invoke ghc with the right options:

{- cabal:
build-depends: base ^>=4.17
default-language: Haskell2010
build-tool-depends: markdown-unlit:markdown-unlit
ghc-options: -pgmL markdown-unlit -Wall -Werror
-}

The above snippet could be put in any kind of section, but I prefer to put it in a haskell code-block, so it’s retained in the output of markdown-unlit.

Next to build-depends and similar fields in a cabal section, configuration used in a cabal.project file can be put in a project section. See the documentation for more details.

With all this in place, articles can be executed using cabal run article.lhs, or even better, loaded in a REPL session, including all dependencies, using cabal repl article.lhs.

Rendering Literate Haskell Articles

By default, Jekyll won’t read .lhs files in the _drafts or _posts folders as Markdown files. By default, it will only read files with the .md extension (and several others) as Markdown. To treat .lhs files the same way, add the following to your site’s _config.yml:

markdown_ext: "markdown,mkdown,mkdn,mkd,md,lhs"

Any .lhs files in the _drafts, _posts and other folders will now be rendered as Markdown sources.

Finishing Up

Finally, let’s wrap things up for this particular article:

main :: IO ()
main = printHelloWorld

and indeed:

$ cabal run _drafts/jekyll-literate-haskell.lhs
Hello, world

Of course, this could launch a tasty test-suite or similar, see here for an example.

Happy hacking^Wwriting!

The above only scratches the surface of what’s possible with STM. To learn more, see chapter 28 of Real World Haskell.

STM makes writing concurrent code with shared mutable state easier, but still leaves room for mistakes. Code with mutable state, especially with concurrent access to shared mutable state, is more difficult to test than pure computations. Using DejaFu, we can write tests of concurrent code which will simulate various schedulings of application threads and validate the result, e.g., by ensuring a program yields the same value no matter the order in which threads were scheduled, or by ensuring some invariants were maintained at every observable point in time. In this post, I want to show two patterns I adopted when writing concurrent code, using STM, with the ability to test it using DejaFu. If you’re not familiar with the latter, you can find more information on its website.

First, some boilerplate so this post can be executed as a Literal Haskell script:

{- cabal: 
build-depends:
  , base ^>=4.17.0.0
  , concurrency ^>=1.11.0.2
  , exceptions ^>=0.10.7
  , tasty ^>=1.4.3
  , tasty-dejafu ^>=2.1.0.0
build-tool-depends: markdown-unlit:markdown-unlit
ghc-options: -threaded -pgmL markdown-unlit -Wall -Werror
default-language: Haskell2010
-}

To test code using DejaFu, it can’t be written using, e.g., readTVar :: TVar a -> STM a, but instead needs to use the abstractions provided by the concurrency package, e.g., readTVar :: MonadSTM stm => TVar stm a -> stm a. Notice how the TVar type is parametrized by the monad in which it’ll be used. This allows for use in the traditional STM monad (which is an instance of MonadSTM), as well as in emulations of it provided by DejaFu.

Furthermore, we’ll use the exceptions package to throw exceptions while checking invariants, and the tasty test framework, including DejaFu integration for it brought by tasty-dejafu to define and run some tests.

All good Haskell code starts with some LANGUAGE pragmas and some imports, so let’s get those out of the way:

{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}

import Control.Concurrent.Classy.Async (concurrently_, wait, withAsync)
import Control.Concurrent.Classy.STM (TVar, readTVar, modifyTVar')
import Control.Monad (unless)
import Control.Monad.Catch (Exception(..), MonadThrow, throwM)
import Control.Monad.Conc.Class (MonadConc, STM, atomically, newTVarConc)
import Control.Monad.STM.Class (MonadSTM)
import Data.Functor.Identity (Identity(..))
import Test.Tasty (defaultMain, testGroup)
import Test.Tasty.DejaFu (Basic, Program, WithSetup, inspectTVar, registerInvariant, testAuto, withSetup)

State and Mutations

In the (admittedly contrived) example used throughout this post, our program keeps track of two Int values, and provides two actions to mutate them: one to add an Int which will add the given value to the first mutable variable and substract it from the second, and another to substract an Int which will, as you may have guessed, substract the given value from the first mutable variable and add it to the second. Hence, there’s an invariant that should be maintained at all times: the sum of both mutable variables should be 0.

State Type

In regular STM code, we’d use a datatype like the following to maintain the state:

data Store = Store
  { storeA :: TVar Int,
    storeB :: TVar Int
  }

This works, but as mentioned before, we need to use the types provided by the concurrency package to be able to test our code using DejaFu. Hence, we need to use its TVar stm a type (family) instead:

data Store stm = Store
  { storeA :: TVar stm Int,
    storeB :: TVar stm Int
  }

This goes in the right direction, and indeed, we could provide implementations for add and sub and test those. However, there are still some shortcomings:

• When checking invariants, writing code doing so in a pure style (modulo throwing exceptions) simplifies the implementation a lot, instead of littering the validation code with readTVar calls and monadic binds. This, in turn, makes testing of the invariants validation code easier as well.

• DejaFu can be used to validate a concurrent computation always yields the same result, which imposes an Eq constraint on the result type. We often want to check the shared mutable state is the same no matter which scheduling of mutators happened, but a data type with TVars inside can’t have an Eq instance.

So, we build Store such that it’s paramterized over a cell type which, for the mutable version of Store will be some TVar, whilst cell can also be Identity in which case the resulting type is immutable:

data Store' cell = Store'
  { storeA :: cell Int,
    storeB :: cell Int
  }

deriving instance (forall a. Show a => Show (cell a)) => Show (Store' cell)
deriving instance (forall a. Eq a => Eq (cell a)) => Eq (Store' cell)

type FrozenStore = Store' Identity
type Store stm = Store' (TVar stm)

As in the above, we can derive a Show and Eq instance for Store' cell as long as there’s a Show and Eq instance for cell a, for all possible as. This is not the case for Store (e.g., there’s no Show instance for TVar stm a), but it is for FrozenStore.

Functions

We can now define a function to create a new Store, and implement add and sub:

newStoreConc :: MonadConc m => m (Store (STM m))
newStoreConc =
  Store'
    <$> newTVarConc 0
    <*> newTVarConc 0

addSTM :: MonadSTM stm => Int -> Store stm -> stm ()
addSTM i store = do
  modifyTVar' (storeA store) (\a -> a + i)
  modifyTVar' (storeB store) (\b -> b - i)

add :: MonadConc m => Int -> Store (STM m) -> m ()
add i store = atomically (addSTM i store)

subSTM :: MonadSTM stm => Int -> Store stm -> stm ()
subSTM i store = do
  modifyTVar' (storeA store) (\a -> a - i)
  modifyTVar' (storeB store) (\b -> b - i)

sub :: MonadConc m => Int -> Store (STM m) -> m ()
sub i store = atomically (subSTM i store)

(Did you spot the bug?)

If the types in the code above are a bit daunting, when specialized to IO we’d get

import Control.Concurrent.STM (STM, TVar)

type Store = Store' TVar

-- | 'newStoreIO', so you want.
newStoreConc :: IO Store

addSTM :: Int -> Store -> STM ()
add :: Int -> Store -> IO ()

subSTM :: Int -> Store -> STM ()
sub :: Int -> Store -> IO ()

Snapshots

The code above works on the mutable version of Store'. However, we went through this cell hassle in order to get an immutable version of a Store' for use in invariant checks and consistency tests. The following functions can be defined to turn a Store stm into an stm FrozenStore:

snapshotWith ::
  Applicative m =>
  (forall a. cell a -> m a) ->
  Store' cell ->
  m FrozenStore
snapshotWith readCell store =
  Store'
    <$> (Identity <$> readCell (storeA store))
    <*> (Identity <$> readCell (storeB store))

snapshotSTM :: MonadSTM stm => Store stm -> stm FrozenStore
snapshotSTM = snapshotWith readTVar

snapshot :: MonadConc m => Store (STM m) -> m FrozenStore
snapshot = atomically . snapshotSTM

The snapshotWith function is where the magic happens. It takes an action which, in some Applicative context, can read the value of a cell, and can then turn a Store' cell into a FrozenStore (where cell is Identity) within said context. snapshotSTM is a utility to work with a MonadSTM stm => Store stm (i.e., snapshotting with readTVar), and snapshot wraps snapshotSTM to run in a MonadConc.

We need snapshotWith, and not only snapshotSTM, for use in DejaFu’s Invariant monad later.

Invariants

Finally, we can define checkInvariants, which ensures invariants are met in a FrozenStore. If not, it throws an InvariantViolation exception:

newtype InvariantViolation = InvariantViolation String
  deriving (Show)

instance Exception InvariantViolation where
  displayException (InvariantViolation msg) = "Invariant violation: " <> msg

invariantViolation :: MonadThrow m => String -> m a
invariantViolation = throwM . InvariantViolation

checkInvariants :: MonadThrow m => FrozenStore -> m ()
checkInvariants store = do
  let Identity a = storeA store
      Identity b = storeB store

  unless (a + b == 0) $
    invariantViolation ("a + b /= 0, a = " <> show a <> ", b = " <> show b)

There are many ways to implement checkInvariants, and the above is only one of them. Some alternatives include

• Making checkInvariants pure, returning, e.g., Either String () or a Bool value, and wrapping it later to turn a non-successful result into an exception (as required by DejaFu).

• Using the Validation monad to capture all invariant violations instead of only the first one, and either returning them or throwing them at the end.

Concurrent Access

With the above code in place, here’s some code using a Store, mutating it concurrently in various ways:

-- | Add two values to a `Store`, concurrently.
concurrentAdd :: MonadConc m => Int -> Int -> Store (STM m) -> m ()
concurrentAdd i j store =
  concurrently_
    (add i store)
    (add j store)

-- | Add two values to a `Store`, concurrently. With a bug.
brokenConcurrentAdd :: MonadConc m => Int -> Int -> Store (STM m) -> m ()
brokenConcurrentAdd i j store =
  withAsync (add i store) $ \a ->
    withAsync (add j store) $ \_ ->
      wait a

-- | Add and substract a value from a `Store`, concurrently.
concurrentAddAndSub :: MonadConc m => Int -> Int -> Store (STM m) -> m ()
concurrentAddAndSub i j store =
  concurrently_
    (add i store)
    (sub j store)

Testing

Finally, we can write some tests for the above code. First, withStore is a helper to create a Store' (within the appropriate DejaFu MonadConc environment), and register an invariant check. The latter will create a FrozenStore from the mutable one using snapshotWith inspectTVar. inspectTVar is a function in DejaFu’s Invariant monad which allows to peek inside the contents of a TVar in the model:

withStore ::
  Monad m =>
  (Store (STM (Program Basic m)) -> Program Basic m a) ->
  Program (WithSetup (Store (STM (Program Basic m)))) m a
withStore = withSetup $ do
  store <- newStoreConc

  registerInvariant $
    checkInvariants =<< snapshotWith inspectTVar store

  pure store

Then, the tests. Each test runs the default DejaFu validations calling one of the concurrent functions on a provisioned Store', and returns a snapshot of the store. DejaFu will then check whether every interleaving of concurrent actions results in the same value/state.

main :: IO ()
main = defaultMain $ testGroup "store-app" [
  testAuto "concurrentAdd" $ withStore $ \store -> do
    concurrentAdd 10 20 store

    snapshot store,

  testAuto "brokenConcurrentAdd" $ withStore $ \store -> do
    brokenConcurrentAdd 10 20 store

    snapshot store,

  testAuto "concurrentAddAndSub" $ withStore $ \store -> do
    concurrentAddAndSub 10 20 store

    snapshot store
  ]

The first test succeeds, as desired:

store-app
  concurrentAdd
    Never Deadlocks:   OK (0.13s)
    No Exceptions:     OK (0.02s)
    Consistent Result: OK (0.02s)

The second one, however, fails, as expected:

  brokenConcurrentAdd
    Never Deadlocks:   OK
    No Exceptions:     OK
    Consistent Result: FAIL
      Failed:
        Store' {storeA = Identity 30, storeB = Identity (-30)} S0-----------S1---------S0---S2---------S0-------------

        Store' {storeA = Identity 10, storeB = Identity (-10)} S0-----------S1---------S0---S2--P0---S2---S0-----------

      Use -p '/brokenConcurrentAdd.Consistent Result/' to rerun this test only.

Indeed, brokenConcurrentAdd fails to wait for the inner Async. Hence, there are two possible interleavings: one where the second add succeeds before the thread running it is killed (the first interleaving above, where storeA is 30), or another one where the thread is killed before its add action has completed, and the snapshotted state has 10 in storeA (the second interleaving above).

The last test also fails, in this case not because some concurrency bug as above, but because the invariants we expect our state to adhere to are violated:

  concurrentAddAndSub
    Never Deadlocks:   OK
    No Exceptions:     OK
    Consistent Result: FAIL
      Failed:
        [invariant failure] S0-------S1--------S2---

        [invariant failure] S0-------S2---

      Use -p '/concurrentAddAndSub.Consistent Result/' to rerun this test only.

2 out of 9 tests failed (0.19s)

Indeed, once the second thread (which runs sub j store) ran, no matter whether the first thread (running add i store) ran before or not, the a + b == 0 invariant no longer holds. Indeed, there’s a bug in the subSTM function: instead of substracting i from storeB, it should add it.

Sadly, at this point tasty-dejafu won’t show which exception was raised while checking invariants, and only displays invariant failure. I opened an issue to maybe improve this.

Conclusion

STM allows for safe concurrent access to shared mutable state with fine-grained locking. However, when multiple variables are at play, defining invariants between their values and ensuring these invariants aren’t breached in some interleaving of concurrent mutations is important. The DejaFu library can help to achieve this, so building your code on the concurrency abstractions from the start allows to write all kinds of tests later.

Future Work

• The trick used above to use Identity as the cell type allows for immutable versions of the data type bundling all variables. However, the Identity wrapper is a bit of a burden when dissecting FrozenStore. It’d be nice if cell a could become a plain a removing the need to unpack the Identity constructor. I have a hunch this might be possible by using some closed type family, but didn’t pursue this further yet.

• Implementing snapshotWith is quite boring. I imagine it’s possible to have a generic version of it using GHC.Generics.

• Using the concurrency abstraction brings a MonadConc or MonadSTM constraint and hence a dictionary lookup at runtime. I’d love to see some benchmarks where a library is defined in terms of MonadConc and MonadSTM, but every function is INLINEABLE and/or SPECIALIZEd to Control.Concurrent.STM.STM and IO so there’s, ideally, no performance hit for regular application consumers of the library vs. using plain STM and IO in the library code. [Update: here’s the answer]

A lot of functionality can be implemented in high-level user-space libraries, but at some point we must interact with the system and its kernel through syscalls. In the GHC Haskell ecosystem, we use the wrappers provided by the system C library instead of directly calling into the kernel, which doesn’t take a lot of effort thanks to GHC’s excellent Foreign Function Interface support. Exposing the

int openat(int dirfd, const char *pathname, int flags)

function from libc to Haskell code is as simple as

foreign import capi safe "fcntl.h openat"
    c_openat :: CInt -> CString -> CInt -> IO CInt

Now Haskell code can call c_openat to open a file.

The above code is, however, a bit too low-level for most practical purposes:

• When openat fails, it returns -1 and errno is set. Checking whether the return value of the c_openat action is -1 is not very Haskell’esque: this is where we expect an exception to be thrown.
• The CInt type is very generic. Instead, we’d like to use a type specific to file-descriptors, so a corresponding read, write or close action will take such type as an argument, not any arbitrary CInt.
• c_openat takes a CString argument, which is a Ptr CChar. In high-level code, this is not a type we regularly work with. An API using a less clumsy path type would be welcome.

Luckily, there’s a popular library in the ecosystem which provides just that: unix. In its System.Posix.IO module, it provides

openFdAt :: Maybe Fd -> FilePath -> OpenMode -> OpenFileFlags -> IO Fd

which is a wrapper around c_openat. It’s using the Fd type where applicable, it will throw an IOError when the call fails using handy utility functions like

Foreign.C.Error.throwErrnoIfMinus1 :: (Eq a, Num a) => String -> IO a -> IO a

and takes a FilePath (a.k.a. String) as argument, internally turning this into a CString for the lifetime of the call to c_openat using

Foreign.C.String.withCString :: String -> (CString -> IO a) -> IO a

Some problems with unix

The unix package has been serving the Haskell ecosystem well for many years (and, without a doubt, for many years to come). However, it’s not without its shortcomings:

• The FilePath type (as used in, e.g., the System.Posix.IO module) being a String comes with performance implications. Hence, the System.Posix.IO module was cloned into System.Posix.IO.ByteString and reworked to use ByteString values as paths. This duplication requires certain code changes to be applied in multiple modules.
• Neither FilePath nor ByteString are suitable types for paths, because of encoding issues. Hence, new clones of applicable modules were created now using PosixPath values (e.g., System.Posix.IO.PosixString), further increasing code-duplication.
• The unix library exposes functions that are not necessarily available on all supported platforms, e.g., the WASM/WASI platform lacks some. Availability of library functions is checked using a configure script at build time, but when some library function is not found, the corresponding binding in unix is implemented, unconditionally, as

  ioError (ioeSetLocation unsupportedOperation "...")
  

  This breaks the “If it compiles, it works” mantra, since any call to the function will most definitely not work.

• unix provides somewhat-high-level access the system functions, though one can argue the wrappers are, sometimes, too high-level, and lower-level interfaces are not made available. As an example, the openAt call above takes an OpenFileFlags argument which is a structure whose fields are mapped to bits in the flags argument of openat. However, if one want to use a flag that’s not available in OpenFileFlags (say, O_PATH on a Linux system), this is not possible. This forced me to implement another set of bindings for openat in landlock-hs: not a lot of effort, but duplication nonetheless.
• Most system functions are effectful (that’s why they exist in the first place), so a big part of the unix API lives in IO. When working with monad stacks layered on top of IO, this requires a lot of liftIOing.

The xinu experiment

To experiment with alternative implementation strategies to expose system functions to Haskell code, I created the xinu package. Actually, two packages:

• xinu-ffi, which exposes FFI bindings to library functions, using a configure script to detect system capabilities. If a library function is not found at configure time, xinu-ffi will not provide a binding to it. Hence, the library API can depend on the build environment. However, a xinu-ffi.h header file is installed so dependent package can detect availability of functions using the CPP language extension.

• xinu, and a couple of internal libraries, which expose higher-level APIs to a developer.

The xinu library, similar to unix, supports multiple path types. However, unlike unix, this is not implemented by copying the modules. Instead, it leverages GHC’s Backpack feature, which brings ML module functor-like functionality to Haskell. Basically, Backpack allows us to write code, abstracted over a module for which we only provide the signature (i.e., the types and functions it must expose). Then, at build time, we can specify one or more implementations of this signature and create instanciations of the abstract module. Hence, without any code duplication, there’s System.Xinu.IO.FilePath and System.Xinu.IO.ByteString, both instanciations of System.Xinu.IO.Abstract (over System.Xinu.Path.FilePath and System.Xinu.Path.ByteString). The latter are two modules implementing a rather simple signature:

signature System.Xinu.Path (
      Path
    , toString
    , withPath
    ) where

import Control.Monad.Catch (MonadMask)
import Control.Monad.IO.Class (MonadIO)
import Foreign.C.String (CString)

data Path

-- Execute an action, passing the given Path as a CString.
withPath :: (MonadIO m, MonadMask m) => Path -> (CString -> m a) -> m a

-- Used for error reporting.
toString :: Path -> String

Unlike the unix library xinu will expose a different API depending on library function availability of the build environment (based on findings of xinu-ffi’s configure script). Similar to xinu-ffi, it provides a xinu.h header file, so dependents who care about availability of functions (e.g., to provide different implementations based on what’s available) can use CPP.

Finally, xinu functions aren’t IO (though they’re SPECIALIZEd for it). Instead, it relies on the MonadIO type-class to liftIO xinu-ffi functions where necessary. Furthermore, errors are reported and (where applicable) safely handled using the MonadThrow and MonadMask type-classes from the exceptions package. This allows xinu functions to be used within arbitrary monad stacks (assuming an instance of MonadIO and MonadThrow/MonadMask is present).

So, xinu-ffi exposes

System.Xinu.IO.FFI.c_openat :: Int32 -> CString -> Int32 -> Word32 -> IO Int32

while xinu exposes, among others,

System.Xinu.IO.FilePath.openat :: (MonadIO m, MonadMask m)
                               => Maybe Int32
                               -> FilePath
                               -> Int32
                               -> Maybe Word32
                               -> m Int32

and

System.Xinu.IO.ByteString.openat :: (MonadIO m, MonadMask m)
                                 => Maybe Int32
                                 -> ByteString
                                 -> Int32
                                 -> Maybe Word32
                                 -> m Int32

Of course, the intent is to use higher-level types (like Fd) instead. This should be fairly simple to do, especially using coerce since indeed, we expect (or rather, require) such Fd to be equal to an Int32 (at least on this platform).

Learnings and Questions

It’s a bit too soon to know where this experiment could be heading. However, some early experiences:

• Backpack doesn’t work when a package has Build-Type Configure, which is a bummer: it forces xinu-ffi to be a separate package, which increases maintenance burden. If it could be a (public) internal library, this would make things quite a bit easier.
• A multi-package repository (using cabal.project) and Backpack seems to trigger a dependency resolution issue in Cabal, causing cabal install --dependencies-only all to fail.
• stack doesn’t support Backpack. This is a known issue but limits adoption of Backpack in the ecosystem, which is a shame, since ML-style module functors are a great way to reduce code duplication without incurring any runtime performance overhead.
• Haddock doesn’t like Mixins, internal libraries and Reexported-Modules. Basically, no decent API documentation of xinu can be generated. There are several related issues filed upstream.
• Given the new OsPath family of types, does it make sense to keep providing FilePath, ByteString and other implementations?
• More tests to ensure exception handling is working as desired are needed. How is this code different from the unliftio package?

Conclusion

Even though xinu is in no way meant to be as extensive as unix, it’s always interesting to explore different approaches to a given problem, especially when new functionality can be leveraged which wasn’t available when the original solution was coded.

I’d love to hear your feedback. Would a library like xinu be of any use to you? What’s missing? Head to the repository’s Discussions section!

Platforms which require machine-generated files to be part of release packages include the JavaScript ecosystem, where often packed and/or minified versions of a set of source files (generated by tools like Gulp or Webpack) are bundled in a distribution, or build systems like the Autotools toolchain (which brings us the familiar ./configure, make, make install procedure) where files like configure and Makefile.in are generated from configure.ac and Makefile.am (and other auxiliary files).

The traditional approach to generate release (source) packages for such projects is to generate the files on a developer machine, or in some CI environment, create a tarball, and store this artifact in a safe location: if one loses this file, it may be impossible to ever recreate an exact copy of the original release. This could e.g. be caused by later versions of the build tools to generate slightly different results for the same input, or these tools using ‘external’ values (including time, randomness,…) during generation.

First Attempt

If the content of these release files is so precious, it makes sense to keep them alongside something which is at least as valuable: the source repository of the codebase, which contains the all code and its history. Given this, one can come up with a scheme like the following:

Whilst this repository now contains a tag to a released tree which contains all generated files, this has a major drawback: it also introduces a subsequent commit (12c6685) which explicitly removes all these generated files again, immediately following the commit in which they were added. Furthermore, this requires one more commit to bump the version number. This clutters the repository history.

Second Attempt

To overcome the sequence of Import generated files and subsequent revert commits, we can try an alternative approach, stashing the imports away in a branch:

Whilst this approach doesn’t require any revert of Import generated files commits, it has another drawback: the relation between tags and branches is lost. As an example, running a command like git describe --tags on the master branch will never result in any release tags to be part of the output.

Final Approach

Fixing the limitations of the previous approach is trivial: we simply need to reinstate a connection between the release tag, and the development branch (master in this example). How does one create a link between two branches? By merging, of course! Here’s how this works:

As-is, this wouldn’t yield the desired result: the merge-commit in 49e527e would result in a tree which contains the generated files (in this specific case the tree at 49e527e would be equal to the package-1.0.0 tree, actually), which is clearly not what we aimed for. Instead, we should run git merge --no-commit when merging package-1.0.0 into master, undo all the changes made in the release-1.0.0 branch (i.e. remove the generated files and reset the version number), only then to git commit the resulting merge. Also note the tag (package-1.0.0) gets merged into master, not the release-1.0.0 branch (which makes only a difference when the tag is annotated, of course).

Aside: you may have noticed the schema above no longer contains a Set version number to 1.0.1-pre commit: this is no longer required, because one may opt to bump the version number as part of the merge commit (49e527e). Some may object against this approach and still keep a separate commit to increase the value. Others may use some specific number for master versions. All of these have pros and cons, pick one and be consistent.

Whilst the approach described above may seem laborious, note it’s fairly easy to automate the workflow. Also, when using Autotools, it’s now possible to release the output of git archive of a release tag, instead of relying on make dist. Validating whether make distcheck passes, and asserting the content of a resulting distribution package resembles an archive generated by Git, e.g. as part of a CI pipeline, is of course good practice!

Finally, this approach interacts nicely with the GitWaterFlow branching model we presented at RELENG’16, but more about that later!

For the curious: the picture above comes from The C Programming Language, First Edition by Kernighan & Ritchie, published in 1978 (archive.org maintains a copy, page 6). Using “Hello, world” as a textbook example for programming languages goes way back.