diff --git a/Control-Monad-MultiPass.cabal b/Control-Monad-MultiPass.cabal
new file mode 100644
--- /dev/null
+++ b/Control-Monad-MultiPass.cabal
@@ -0,0 +1,86 @@
+-- Copyright 2013 Kevin Backhouse.
+
+name:                Control-Monad-MultiPass
+version:             0.1.0.0
+synopsis:            A Library for Writing Multi-Pass Algorithms.
+description:         The MultiPass library supports a monadic programming
+                     idiom in which multi-pass algorithms are written
+                     in a single-pass style.
+homepage:            https://github.com/kevinbackhouse/Control-Monad-MultiPass
+license:             BSD3
+license-file:        LICENSE
+author:              Kevin Backhouse
+maintainer:          Kevin.Backhouse@gmail.com
+copyright:           Kevin Backhouse, 2013
+category:            Control
+build-type:          Simple
+cabal-version:       >=1.8
+Extra-source-files:  README.txt
+tested-with:         GHC==7.6.2
+library
+  exposed-modules:   Control.Monad.MultiPass,
+                     Control.Monad.MultiPass.Utils,
+                     Control.Monad.MultiPass.Utils.InstanceTest,
+                     Control.Monad.MultiPass.Utils.UpdateCtx,
+                     Control.Monad.MultiPass.ThreadContext.CounterTC,
+                     Control.Monad.MultiPass.ThreadContext.MonoidTC,
+                     Control.Monad.MultiPass.Instrument.Counter,
+                     Control.Monad.MultiPass.Instrument.CreateST2Array,
+                     Control.Monad.MultiPass.Instrument.Delay,
+                     Control.Monad.MultiPass.Instrument.DelayedLift,
+                     Control.Monad.MultiPass.Instrument.EmitST2Array,
+                     Control.Monad.MultiPass.Instrument.EmitST2ArrayFxp,
+                     Control.Monad.MultiPass.Instrument.Knot3,
+                     Control.Monad.MultiPass.Instrument.Monoid2,
+                     Control.Monad.MultiPass.Instrument.OrdCons,
+                     Control.Monad.MultiPass.Instrument.TopKnot,
+                     Control.Monad.MultiPass.Example.Assembler,
+                     Control.Monad.MultiPass.Example.CFG,
+                     Control.Monad.MultiPass.Example.CFG2,
+                     Control.Monad.MultiPass.Example.Counter,
+                     Control.Monad.MultiPass.Example.Localmin,
+                     Control.Monad.MultiPass.Example.OrdCons,
+                     Control.Monad.MultiPass.Example.Repmin,
+                     Control.Monad.MultiPass.Example.StringInterning
+  hs-source-dirs:    src
+  build-depends:     base >= 4.5 && < 5, array, mtl, containers,
+                     Control-Monad-ST2
+  ghc-options:       -Wall
+  extensions:        Safe,
+                     DeriveFunctor,
+                     Rank2Types,
+                     ExistentialQuantification,
+                     MultiParamTypeClasses,
+                     FunctionalDependencies,
+                     FlexibleInstances,
+                     FlexibleContexts,
+                     UndecidableInstances
+
+source-repository this
+  type:      git
+  location:  https://github.com/kevinbackhouse/Control-Monad-MultiPass.git
+  tag:       Version-0.1.0.0
+
+test-suite Main
+  type:              exitcode-stdio-1.0
+  x-uses-tf:         true
+  build-depends:     base >= 4.5 && < 5, array, mtl, containers,
+                     QuickCheck,
+                     Control-Monad-ST2,
+                     test-framework,
+                     test-framework-quickcheck2,
+                     test-framework-hunit
+  ghc-options:       -Wall -threaded -with-rtsopts=-N
+  extensions:        DeriveFunctor,
+                     Rank2Types,
+                     ExistentialQuantification,
+                     MultiParamTypeClasses,
+                     FunctionalDependencies,
+                     FlexibleInstances,
+                     FlexibleContexts,
+                     UndecidableInstances
+  hs-source-dirs:    src, src/Control, src/Control/Monad,
+                     src/Control/Monad/MultiPass,
+                     src/Control/Monad/MultiPass/Example,
+                     tests
+  main-is:           Main.hs
diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,30 @@
+Copyright (c) 2013, Kevin Backhouse
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Kevin Backhouse nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
diff --git a/README.txt b/README.txt
new file mode 100644
--- /dev/null
+++ b/README.txt
@@ -0,0 +1,2 @@
+Control-Concurrent-MultiPass
+============================
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,4 @@
+-- Copyright 2013 Kevin Backhouse.
+
+import Distribution.Simple
+main = defaultMain
diff --git a/src/Control/Monad/MultiPass.hs b/src/Control/Monad/MultiPass.hs
new file mode 100644
--- /dev/null
+++ b/src/Control/Monad/MultiPass.hs
@@ -0,0 +1,972 @@
+-- Copyright 2013 Kevin Backhouse.
+
+{-# OPTIONS_GHC -XPolyKinds -XKindSignatures -XScopedTypeVariables #-}
+
+{-|
+
+This module implements the core functions, datatypes, and classes of
+the MultiPass library. Its export list is divided into two halves. The
+first half contains the declarations which are relevant to anyone who
+wants to use the MultiPass library. The second contains which are only
+relevant to people who want to implement new instruments.
+
+-}
+
+module Control.Monad.MultiPass
+  ( -- * Users
+    MultiPass
+  , MultiPassPrologue
+  , MultiPassEpilogue
+  , MultiPassMain, mkMultiPassMain
+  , PassS(..), PassZ(..)
+  , MultiPassAlgorithm(..)
+  , run
+  , NumThreads(..)
+  , parallelMP, parallelMP_
+  , readOnlyST2ToMP
+
+    -- * Instrument Authors
+  , On(..), Off(..)
+  , MultiPassBase
+  , mkMultiPass, mkMultiPassPrologue, mkMultiPassEpilogue
+  , WrapInstrument, wrapInstrument
+  , PassNumber
+  , StepDirection(..)
+  , ST2ToMP
+  , UpdateThreadContext
+  , Instrument(..)
+  , ThreadContext(..)
+  , NextThreadContext(..)
+  , NextGlobalContext(..)
+  , BackTrack(..)
+  )
+where
+
+import Control.Exception ( assert )
+import Control.Monad.State.Strict
+import Control.Monad.ST2
+import Data.Ix
+
+-- | This datatype is used in conjunction with 'PassZ' to package the
+-- main function of the multi-pass algorithm. For an example of how
+-- they are used, see the implementation of
+-- 'Control.Monad.MultiPass.Example.Repmin.repminMP' or any of the
+-- other examples in the Example directory.
+newtype PassS cont m
+  = PassS (forall p. Monad p => cont (m p))
+
+-- | Used in conjunction with 'PassS' to build a Peano number
+-- corresponding to the number of passes.
+newtype PassZ f
+  = PassZ (forall (tc :: *). f tc)
+
+-- | The main function of a multi-pass algorithm needs to be wrapped
+-- in a newtype so that it can be packaged with 'PassS' and
+-- 'PassZ'. The newtype needs to be made an instance of
+-- 'MultiPassAlgorithm' so that it can unwrapped by the
+-- implementation.
+class MultiPassAlgorithm a b | a -> b where
+  unwrapMultiPassAlgorithm :: a -> b
+
+-- | Trivial monad, equivalent to 'Data.Functor.Identity.Identity'.
+-- Used to switch on a pass of a multi-pass algorithm.
+newtype On a = On a deriving Functor
+
+instance Monad On where
+  return x = On x
+  On x >>= f = f x
+
+-- | Trivial monad which computes absolutely nothing. It is used to
+-- switch off a pass of a multi-pass algorithm.
+data Off (a :: *) = Off deriving Functor
+
+instance Monad Off where
+  return _ = Off
+  Off >>= _ = Off
+
+-- ArgCons and ArgNil are used to uncurry the main function of the
+-- multi-pass algorithm. For example, a function of the following
+-- type:
+--
+--     Instrument1 -> Instrument2 -> MultiPass r w tc a
+--
+-- gets converted to a function of type:
+--
+--     ArgCons Instrument1 (ArgCons Instrument2 ArgNil) ->
+--     MultiPass r w tc a
+--
+-- The uncurrying is implemented in the ApplyArg and ApplyArgs
+-- classes.
+--
+-- ArgCons and ArgNil are not exported from this module.
+data ArgCons a b
+  = ArgCons !a !b
+
+data ArgNil
+  = ArgNil
+
+mapArgCons :: (a -> a') -> (b -> b') -> (ArgCons a b) -> (ArgCons a' b')
+mapArgCons f g (ArgCons x y) =
+  ArgCons (f x) (g y)
+
+-- The Param type is the old solution to the problem of passing
+-- initial parameters to instruments. The MultiPassPrologue seems to
+-- be a better solution to this problem, so the Param type has been
+-- removed from the external interface. However, all the internal
+-- plumbing is still there (in ApplyArg and ApplyArgs), so it would be
+-- easy to resurrect if necessary. The comments below are the old
+-- comments explaining how to use Param.
+--
+-- This type is used by instruments that are parameterised by an
+-- initial value. It is used in the main function of the algorithm as
+-- follows:
+--
+--    mainFcn =
+--      Param initVal1 $ \instr1 ->
+--      Param initVal2 $ \instr2 ->
+--      do ...
+--
+-- The initial values are passed to the createInstrument method of the
+-- Instrument class so that they can be used during the construction
+-- of the instrument. This is implemented in the ApplyArg and
+-- ApplyArgs classes.
+data Param i f
+  = Param !i !f
+
+-- | This datatype is used by the 'NextThreadContext' and
+-- 'NextGlobalContext' classes to specify whether the algorithm is
+-- progressing to the next pass or back-tracking to a previous
+-- pass. When back-tracking occurs, the current thread and global
+-- contexts are first passed the 'StepReset' command. Then they are
+-- passed the 'StepBackward' command @N@ times, where @N@ is the
+-- number of passes that need to be revisited. Note that @N@ can be
+-- zero if only the current pass needs to be revisited, so the
+-- 'StepBackward' command may not be used. This is the reason why the
+-- 'StepReset' command is always issued first.
+data StepDirection
+  = StepForward
+  | StepReset
+  | StepBackward
+    deriving Eq
+
+-- | This datatype is used by the back-tracking mechanism. Instruments
+-- can request that the evaluator back-tracks to a specific pass
+-- number. Instruments which use back-tracking store the relevant
+-- PassNumbers in their global context. The current 'PassNumber' is
+-- the first argument of 'nextGlobalContext' for this
+-- purpose. 'PassNumber' is an abstract datatype. Instruments should
+-- never need to create a new 'PassNumber' or modify an existing one,
+-- so no functions that operate on 'PassNumber' are exported from this
+-- module.
+newtype PassNumber = PassNumber { unwrapPassNumber :: Int }
+
+-- Increment a PassNumber. This function is not exported.
+incrPassNumber :: PassNumber -> PassNumber
+incrPassNumber (PassNumber k) =
+  PassNumber (k+1)
+
+-- Compute the minimum of two PassNumbers. This function is not
+-- exported.
+minPassNumber :: PassNumber -> PassNumber -> PassNumber
+minPassNumber (PassNumber x) (PassNumber y) =
+  PassNumber (min x y)
+
+-- | 'MultiPass', 'MultiPassPrologue', and 'MultiPassEpilogue' are
+-- trivial newtype wrappers around this monad. Instruments can
+-- construct computations in the 'MultiPassBase' monad, but then use
+-- 'mkMultiPass', 'mkMultiPassPrologue', and 'mkMultiPassEpilogue' to
+-- restrict which of the three stages it is allowed to be used in.
+newtype MultiPassBase r w tc a
+  = MultiPassBase
+      { unwrapMultiPassBase
+          :: ThreadContext r w tc => StateT tc (ST2 r w) a
+      }
+    deriving Functor
+
+instance Monad (MultiPassBase r w tc) where
+  return x = MultiPassBase $ return x
+
+  MultiPassBase m >>= f =
+    MultiPassBase $
+    do x <- m
+       unwrapMultiPassBase (f x)
+
+-- | This monad is used to implement the body of a multi-pass
+-- algorithm.
+newtype MultiPass r w tc a
+  = MultiPass
+      { unwrapMultiPass :: MultiPassBase r w tc a
+      }
+    deriving Functor
+
+instance Monad (MultiPass r w tc) where
+  return x = MultiPass $ return x
+
+  MultiPass m >>= f =
+    MultiPass $
+    do x <- m
+       unwrapMultiPass (f x)
+
+-- | Restrict a computation so that it can only be executed during the
+-- body of the algorithm (not the prologue or epilogue).
+mkMultiPass :: MultiPassBase r w tc a -> MultiPass r w tc a
+mkMultiPass =
+  MultiPass
+
+-- | This monad is used to implement the prologue of a multi-pass
+-- algorithm.
+newtype MultiPassPrologue r w tc a
+  = MultiPassPrologue
+      { unwrapMultiPassPrologue :: MultiPassBase r w tc a
+      }
+    deriving Functor
+
+instance Monad (MultiPassPrologue r w tc) where
+  return x = MultiPassPrologue $ return x
+
+  MultiPassPrologue m >>= f =
+    MultiPassPrologue $
+    do x <- m
+       unwrapMultiPassPrologue (f x)
+
+-- | Restrict a computation so that it can only be executed during the
+-- prologue.
+mkMultiPassPrologue
+  :: MultiPassBase r w tc a -> MultiPassPrologue r w tc a
+mkMultiPassPrologue =
+  MultiPassPrologue
+
+-- | This monad is used to implement the epilogue of a multi-pass
+-- algorithm.
+newtype MultiPassEpilogue r w tc a
+  = MultiPassEpilogue
+      { unwrapMultiPassEpilogue :: MultiPassBase r w tc a
+      }
+    deriving Functor
+
+instance Monad (MultiPassEpilogue r w tc) where
+  return x = MultiPassEpilogue $ return x
+
+  MultiPassEpilogue m >>= f =
+    MultiPassEpilogue $
+    do x <- m
+       unwrapMultiPassEpilogue (f x)
+
+-- | Restrict a computation so that it can only be executed during the
+-- epilogue.
+mkMultiPassEpilogue
+  :: MultiPassBase r w tc a -> MultiPassEpilogue r w tc a
+mkMultiPassEpilogue =
+  MultiPassEpilogue
+
+-- | 'MultiPassMain' is an abstract datatype containing the prologue,
+-- body, and epilogue of a multi-pass algorithm. Use
+-- 'mkMultiPassMain' to construct an object of type 'MultiPassMain'.
+data MultiPassMain r w tc c =
+  forall a b.
+  MultiPassMain
+    !(MultiPassPrologue r w tc a)
+    !(a -> MultiPass r w tc b)
+    !(b -> MultiPassEpilogue r w tc c)
+
+-- | Combine the prologue, body, and epilogue of a multi-pass
+-- algorithm to create the 'MultiPassMain' object which is required by
+-- the 'run' function.
+mkMultiPassMain
+  :: MultiPassPrologue r w tc a           -- ^ Prologue
+  -> (a -> MultiPass r w tc b)            -- ^ Algorithm body
+  -> (b -> MultiPassEpilogue r w tc c)    -- ^ Epilogue
+  -> MultiPassMain r w tc c
+mkMultiPassMain prologue body epilogue =
+  MultiPassMain prologue body epilogue
+
+-- Run the prologue, body, and epilogue of a multi-pass algorithm.
+runMultiPassMain
+  :: ThreadContext r w tc
+  => MultiPassMain r w tc a
+  -> tc
+  -> ST2 r w (a, tc)
+runMultiPassMain (MultiPassMain prologue body epilogue) =
+  runStateT $
+  do x <- unwrapMultiPassBase $ unwrapMultiPassPrologue $ prologue
+     y <- unwrapMultiPassBase $ unwrapMultiPass $ body x
+     unwrapMultiPassBase $ unwrapMultiPassEpilogue $ epilogue y
+
+-- | This class is used when multiple threads are
+-- spawned. 'splitThreadContext' is used to create a new thread
+-- context for each of the new threads and 'mergeThreadContext' is
+-- used to merge them back together when the parallel region ends.
+class ThreadContext r w tc where
+  splitThreadContext
+    :: Int                 -- Number of threads being created
+    -> Int                 -- Index of current thread
+    -> tc                  -- Current thread context
+    -> ST2 r w tc          -- New sub-context
+
+  mergeThreadContext
+    :: Int                 -- Number of threads being merged
+    -> (Int -> ST2 r w tc) -- Function to get the i'th sub-context
+    -> tc                  -- Previous merged context
+    -> ST2 r w tc          -- New merged context
+
+instance ThreadContext r w () where
+  splitThreadContext _ _ () = return ()
+  mergeThreadContext _ _ () = return ()
+
+instance ThreadContext r w ArgNil where
+  splitThreadContext _ _ ArgNil = return ArgNil
+  mergeThreadContext _ _ ArgNil = return ArgNil
+
+instance (ThreadContext r w x, ThreadContext r w y) =>
+         ThreadContext r w (ArgCons x y) where
+  splitThreadContext m t (ArgCons x y) =
+    do x' <- splitThreadContext m t x
+       y' <- splitThreadContext m t y
+       return (ArgCons x' y')
+
+  mergeThreadContext m getSubContext (ArgCons x y) =
+    let getSubContextL tc =
+          do ArgCons tc' _ <- getSubContext tc
+             return tc'
+    in
+    let getSubContextR tc =
+          do ArgCons _ tc' <- getSubContext tc
+             return tc'
+    in
+    do x' <- mergeThreadContext m getSubContextL x
+       y' <- mergeThreadContext m getSubContextR y
+       return (ArgCons x' y')
+
+instance (ThreadContext r w x, ThreadContext r w y) =>
+         ThreadContext r w (x,y) where
+  splitThreadContext m t (x,y) =
+    do x' <- splitThreadContext m t x
+       y' <- splitThreadContext m t y
+       return (x', y')
+
+  mergeThreadContext m getSubContext (x,y) =
+    let getSubContextL tc =
+          do (tc',_) <- getSubContext tc
+             return tc'
+    in
+    let getSubContextR tc =
+          do (_,tc') <- getSubContext tc
+             return tc'
+    in
+    do x' <- mergeThreadContext m getSubContextL x
+       y' <- mergeThreadContext m getSubContextR y
+       return (x',y')
+
+instance ( ThreadContext r w x
+         , ThreadContext r w y
+         , ThreadContext r w z
+         ) =>
+         ThreadContext r w (x,y,z) where
+  splitThreadContext m t (x,y,z) =
+    do x' <- splitThreadContext m t x
+       y' <- splitThreadContext m t y
+       z' <- splitThreadContext m t z
+       return (x', y', z')
+
+  mergeThreadContext m getSubContext (x,y,z) =
+    let getSubContext1 tc =
+          do (tc',_,_) <- getSubContext tc
+             return tc'
+    in
+    let getSubContext2 tc =
+          do (_,tc',_) <- getSubContext tc
+             return tc'
+    in
+    let getSubContext3 tc =
+          do (_,_,tc') <- getSubContext tc
+             return tc'
+    in
+    do x' <- mergeThreadContext m getSubContext1 x
+       y' <- mergeThreadContext m getSubContext2 y
+       z' <- mergeThreadContext m getSubContext3 z
+       return (x',y',z')
+
+-- If the initial thread context is Left then splitThreadContext
+-- creates only Left thread contexts. Similarly, mergeThreadContext
+-- expects all the sub-contexts to match each other.
+instance (ThreadContext r w x, ThreadContext r w y) =>
+         ThreadContext r w (Either x y) where
+  splitThreadContext m t e =
+    case e of
+      Left x
+        -> do x' <- splitThreadContext m t x
+              return (Left x')
+
+      Right y
+        -> do y' <- splitThreadContext m t y
+              return (Right y')
+
+  mergeThreadContext m getSubContext e =
+    let getSubContextL tc =
+          do Left tc' <- getSubContext tc
+             return tc'
+    in
+    let getSubContextR tc =
+          do Right tc' <- getSubContext tc
+             return tc'
+    in
+    case e of
+      Left tc
+        -> do tc' <- mergeThreadContext m getSubContextL tc
+              return (Left tc')
+
+      Right tc
+        -> do tc' <- mergeThreadContext m getSubContextR tc
+              return (Right tc')
+
+{-|
+
+Every instrument must define an instance of this class for each of its
+passes. For example, the
+'Control.Monad.MultiPass.Instrument.Counter.Counter' instrument
+defines the following instances:
+
+> instance Instrument tc () () () (Counter i r w Off Off tc)
+>
+> instance Num i =>
+>          Instrument tc (CounterTC1 i r) () (Counter i r w On Off tc)
+>
+> instance Num i =>
+>          Instrument tc (CounterTC2 i r) () (Counter i r w On On tc)
+
+The functional dependency from @instr@ to @tc@ and @gc@ enables the
+'run' function to automatically deduce the type of the thread context
+and global context for each pass.
+-}
+class Instrument rootTC tc gc instr | instr -> tc gc where
+  createInstrument
+    :: ST2ToMP rootTC
+    -> UpdateThreadContext rootTC tc
+    -> gc                          -- ^ Global context
+    -> WrapInstrument instr        -- ^ Instrument
+
+-- | This abstract datatype is used as the result type of
+-- createInstrument. Instrument authors can create it using the
+-- 'wrapInstrument' function, but cannot unwrap it. This ensures that
+-- instruments can only be constructed by the "Control.Monad.MultiPass"
+-- library.
+newtype WrapInstrument instr
+  = WrapInstrument instr
+    deriving Functor
+
+instance Monad WrapInstrument where
+  return x = WrapInstrument x
+  WrapInstrument x >>= f = f x
+
+-- | Create an object of type 'WrapInstrument'. It is needed when
+-- defining a new instance of the 'Instrument' class.
+wrapInstrument :: instr -> WrapInstrument instr
+wrapInstrument = WrapInstrument
+
+-- | The type of the first argument of 'createInstrument'. It enables
+-- instruments to run 'ST2' in the 'MultiPassBase' monad. (Clearly the
+-- @st2ToMP@ argument needs to be used with care.)
+type ST2ToMP tc
+  = forall r w a. ST2 r w a -> MultiPassBase r w tc a
+
+-- | The type of the first argument of 'createInstrument'. It used to
+-- read and write the thread context.
+type UpdateThreadContext tc tc'
+  = forall r w. (tc' -> tc') -> MultiPassBase r w tc tc'
+
+updateCtxArgL
+  :: UpdateThreadContext rootTC (ArgCons tc tcs)
+  -> UpdateThreadContext rootTC tc
+updateCtxArgL updateCtx h =
+  do ArgCons x _ <- updateCtx (mapArgCons h id)
+     return x
+
+updateCtxArgR
+  :: UpdateThreadContext rootTC (ArgCons tc tcs)
+  -> UpdateThreadContext rootTC tcs
+updateCtxArgR updateCtx h =
+  do ArgCons _ y <- updateCtx (mapArgCons id h)
+     return y
+
+class ApplyArg r w param instr f oldTC oldGC tc gc rootTC f'
+             | f -> f' tc gc where
+  applyArg
+    :: PassNumber
+    -> StepDirection
+    -> param
+    -> (instr -> f)
+    -> UpdateThreadContext rootTC tc
+    -> oldTC
+    -> oldGC
+    -> ST2 r w (f', tc, gc)
+
+instance ( ApplyArgs r w f oldTCs oldGCs tcs gcs rootTC f'
+         , NextThreadContext r w oldTC oldGC tc
+         , NextGlobalContext r w oldTC oldGC gc
+         , Instrument rootTC tc gc instr
+         ) =>
+         ApplyArg r w param instr f
+                  (ArgCons oldTC oldTCs) (ArgCons oldGC oldGCs)
+                  (ArgCons tc tcs) (ArgCons gc gcs)
+                  rootTC f' where
+  applyArg n d _ f updateCtx
+           (ArgCons oldTC oldTCs) (ArgCons oldGC oldGCs) =
+    do gc <- nextGlobalContext n d oldTC oldGC
+       tc <- nextThreadContext n d oldTC oldGC
+       let st2ToMP m = MultiPassBase $ lift m
+       let WrapInstrument instr =
+             createInstrument st2ToMP (updateCtxArgL updateCtx) gc
+       (f', tcs, gcs) <-
+         applyArgs n d (f instr) (updateCtxArgR updateCtx) oldTCs oldGCs
+       return (f', ArgCons tc tcs, ArgCons gc gcs)
+
+class ApplyArgs r w f oldTC oldGC tc gc rootTC f' | f -> f' tc gc where
+  applyArgs
+    :: PassNumber
+    -> StepDirection
+    -> f
+    -> UpdateThreadContext rootTC tc
+    -> oldTC
+    -> oldGC
+    -> ST2 r w (f', tc, gc)
+
+instance ApplyArg r w () instr f oldTC oldGC tc gc rootTC f' =>
+         ApplyArgs r w (instr -> f) oldTC oldGC tc gc rootTC f' where
+  applyArgs n d f updateCtx oldTC oldGC =
+    applyArg n d () f updateCtx oldTC oldGC
+
+instance ApplyArg r w param instr f oldTC oldGC tc gc rootTC f' =>
+         ApplyArgs r w (Param param (instr -> f)) oldTC oldGC
+                   tc gc rootTC f' where
+  applyArgs n d (Param param f) updateCtx oldTC oldGC =
+    applyArg n d param f updateCtx oldTC oldGC
+
+instance ApplyArgs r w (MultiPassMain r w rootTC a)
+                   ArgNil ArgNil ArgNil ArgNil
+                   rootTC (MultiPassMain r w rootTC a) where
+  applyArgs _ _ f _ ArgNil ArgNil =
+    return (f, ArgNil, ArgNil)
+
+class InitCtx ctx where
+  initCtx :: ctx
+
+instance InitCtx () where
+  initCtx = ()
+
+instance InitCtx ArgNil where
+  initCtx = ArgNil
+
+instance (InitCtx a , InitCtx b) =>
+         InitCtx (ArgCons a b) where
+  initCtx = ArgCons initCtx initCtx
+
+-- | This class is used to create the next thread context when the
+-- multi-pass algorithm proceeds to the next pass or back-tracks to
+-- the previous pass.
+class NextThreadContext r w tc gc tc' where
+  nextThreadContext
+    :: PassNumber
+    -> StepDirection  -- Stepping forwards or backwards?
+    -> tc             -- Old thread context
+    -> gc             -- Old global context
+    -> ST2 r w tc'    -- New thread context
+
+instance NextThreadContext r w tc gc () where
+  nextThreadContext _ _ _ _ = return ()
+
+instance ( NextThreadContext r w x gc x'
+         , NextThreadContext r w y gc y'
+         ) =>
+         NextThreadContext r w (x,y) gc (x',y') where
+  nextThreadContext n d (x,y) gc =
+    do x' <- nextThreadContext n d x gc
+       y' <- nextThreadContext n d y gc
+       return (x',y')
+
+instance ( NextThreadContext r w () gc x
+         , NextThreadContext r w () gc y
+         ) =>
+         NextThreadContext r w () gc (x,y) where
+  nextThreadContext n d () gc =
+    do x <- nextThreadContext n d () gc
+       y <- nextThreadContext n d () gc
+       return (x,y)
+
+instance ( NextThreadContext r w x gc x'
+         , NextThreadContext r w y gc y'
+         , NextThreadContext r w z gc z'
+         ) =>
+         NextThreadContext r w (x,y,z) gc (x',y',z') where
+  nextThreadContext n d (x,y,z) gc =
+    do x' <- nextThreadContext n d x gc
+       y' <- nextThreadContext n d y gc
+       z' <- nextThreadContext n d z gc
+       return (x',y',z')
+
+instance ( NextThreadContext r w () gc x
+         , NextThreadContext r w () gc y
+         , NextThreadContext r w () gc z
+         ) =>
+         NextThreadContext r w () gc (x,y,z) where
+  nextThreadContext n d () gc =
+    do x <- nextThreadContext n d () gc
+       y <- nextThreadContext n d () gc
+       z <- nextThreadContext n d () gc
+       return (x,y,z)
+
+instance ( NextThreadContext r w x gc x'
+         , NextThreadContext r w y gc y'
+         ) =>
+         NextThreadContext r w (Either x y) gc (Either x' y') where
+  nextThreadContext n d e gc =
+    case e of
+      Left x
+        -> do x' <- nextThreadContext n d x gc
+              return (Left x')
+
+      Right y
+        -> do y' <- nextThreadContext n d y gc
+              return (Right y')
+
+
+-- | This class is used to create the next global context when the
+-- multi-pass algorithm proceeds to the next pass or back-tracks to
+-- the previous pass.
+class NextGlobalContext r w tc gc gc' where
+  nextGlobalContext
+    :: PassNumber
+    -> StepDirection  -- Stepping forwards or backwards?
+    -> tc             -- Old thread context
+    -> gc             -- Old global context
+    -> ST2 r w gc'    -- New global context
+
+instance NextGlobalContext r w tc gc () where
+  nextGlobalContext _ _ _ _ = return ()
+
+instance ( NextGlobalContext r w tc x x'
+         , NextGlobalContext r w tc y y'
+         ) =>
+         NextGlobalContext r w tc (x,y) (x',y') where
+  nextGlobalContext n d tc (x,y) =
+    do x' <- nextGlobalContext n d tc x
+       y' <- nextGlobalContext n d tc y
+       return (x',y')
+
+instance ( NextGlobalContext r w tc x x'
+         , NextGlobalContext r w tc y y'
+         , NextGlobalContext r w tc z z'
+         ) =>
+         NextGlobalContext r w tc (x,y,z) (x',y',z') where
+  nextGlobalContext n d tc (x,y,z) =
+    do x' <- nextGlobalContext n d tc x
+       y' <- nextGlobalContext n d tc y
+       z' <- nextGlobalContext n d tc z
+       return (x',y',z')
+
+instance ( NextGlobalContext r w tc x x'
+         , NextGlobalContext r w tc y y'
+         ) =>
+         NextGlobalContext r w tc (Either x y) (Either x' y') where
+  nextGlobalContext n d tc e =
+    case e of
+      Left x
+        -> do x' <- nextGlobalContext n d tc x
+              return (Left x')
+
+      Right y
+        -> do y' <- nextGlobalContext n d tc y
+              return (Right y')
+
+class InstantiatePasses a b | a -> b where
+  instantiatePasses :: a -> PassZ b
+
+instance InstantiatePasses (PassZ a) a where
+  instantiatePasses (PassZ x) = PassZ x
+
+instance InstantiatePasses (cont (m Off)) b =>
+         InstantiatePasses (PassS cont m) b where
+  instantiatePasses (PassS f) =
+    instantiatePasses (f :: cont (m Off))
+
+-- | Every instrument must define an instance of this class for each
+-- of its passes. It is used to tell the evaluator whether it needs to
+-- back-track. Instruments which do not back-track should use the
+-- default implementation of backtrack which returns 'Nothing' (which
+-- means that no back-tracking is necessary.) If more than one
+-- instrument requests that the evaluator back-tracks then the
+-- evaluator will back-track to the earliest of the requested passes.
+class BackTrack r w tc gc where
+  backtrack :: tc -> gc -> ST2 r w (Maybe PassNumber)
+  backtrack _ _ = return Nothing
+
+-- If the global context is the unit type then the instrument does not
+-- back-track.
+instance BackTrack r w tc ()
+
+instance BackTrack r w ArgNil ArgNil
+
+instance (BackTrack r w tc gc, BackTrack r w tcs gcs) =>
+         BackTrack r w (ArgCons tc tcs) (ArgCons gc gcs) where
+  backtrack (ArgCons tc tcs) (ArgCons gc gcs) =
+    do mx <- backtrack tc gc
+       my <- backtrack tcs gcs
+       case (mx,my) of
+         (Nothing, Nothing) -> return Nothing
+         (Nothing, Just y)  -> return (Just y)
+         (Just x, Nothing)  -> return (Just x)
+         (Just x, Just y)   -> return (Just (minPassNumber x y))
+
+class RunPasses r w f tc gc p out where
+  runPasses
+    :: PassNumber -> f -> p out -> tc -> gc
+    -> ST2 r w
+        (Either
+           ( PassNumber
+           , MultiPassMain r w tc (p out)
+           , tc
+           , gc
+           )
+           out)
+
+instance RunPasses r w (PassZ f) tc gc On out where
+  runPasses _ _ (On out) _ _ =
+    return (Right out)
+
+instance ( InstantiatePasses (cont (f Off)) fPrev
+         , MultiPassAlgorithm (fPrev tc0) gPrev
+         , InstantiatePasses (cont (f On)) fCurr
+         , MultiPassAlgorithm (fCurr tc1) gCurr
+         , ApplyArgs r w gCurr tc0 gc0 tc1 gc1 tc1
+                     (MultiPassMain r w tc1 (p out))
+         , ApplyArgs r w gCurr tc1 gc1 tc1 gc1 tc1
+                     (MultiPassMain r w tc1 (p out))
+         , ApplyArgs r w gPrev tc1 gc1 tc0 gc0 tc0
+                     (MultiPassMain r w tc0 (q out))
+         , ThreadContext r w tc1
+         , BackTrack r w tc1 gc1
+         , RunPasses r w (cont (f On)) tc1 gc1 p out
+         ) =>
+         RunPasses r w (PassS cont f) tc0 gc0 q out where
+  runPasses n fBox _ =
+    let PassS (fPrev :: cont (f Off)) = fBox in
+    let PassS (fCurr :: cont (f On)) = fBox in
+    let -- Loop header. Run the current pass and check whether
+        -- back-tracking is necessary.
+        loop g tc gc =
+          do (result, tc') <- runMultiPassMain g tc
+             mb <- backtrack tc' gc
+             case mb of
+               Nothing
+                 -> -- Current pass is successful, so continue to
+                    -- the next pass.
+                    let n' = incrPassNumber n in
+                    do e <- runPasses n' fCurr result tc' gc
+                       case e of
+                         Left info -> rewind info
+                         Right out -> return (Right out)
+
+               Just m
+                 -> stepReset m tc' gc
+
+        -- Call either loop or stepBackward, depending on the
+        -- PassNumber.
+        rewind (m,g,tc,gc) =
+          assert (unwrapPassNumber m <= unwrapPassNumber n) $
+          if unwrapPassNumber m == unwrapPassNumber n
+             then loop g tc gc
+             else stepBackward m tc gc
+
+        -- Reset the contexts and rewind to the requested pass number.
+        stepReset m tc gc =
+          let PassZ f' = instantiatePasses fCurr in
+          let g = unwrapMultiPassAlgorithm (f' :: fCurr tc1) in
+          do (g', tc', gc') <-
+               applyArgs n StepReset g updateThreadContextTop tc gc
+             rewind (m,g',tc',gc')
+
+        -- Return to the previous pass.
+        stepBackward m tc gc =
+          let PassZ f' = instantiatePasses fPrev in
+          let g = unwrapMultiPassAlgorithm (f' :: fPrev tc0) in
+          do (g', tc', gc') <-
+               applyArgs n StepBackward g updateThreadContextTop tc gc
+             return (Left (m,g',tc',gc'))
+    in
+    let loopStart tc gc =
+          let PassZ f' = instantiatePasses fCurr in
+          let g = unwrapMultiPassAlgorithm (f' :: fCurr tc1) in
+          do (g', tc', gc') <-
+               applyArgs n StepForward g updateThreadContextTop tc gc
+             loop g' tc' gc'
+    in
+    loopStart
+
+updateThreadContextTop :: UpdateThreadContext tc tc
+updateThreadContextTop f =
+  MultiPassBase $
+  do tc <- get
+     put (f tc)
+     return tc
+
+-- | This function is used to run a multi-pass algorithm. Its
+-- complicated type is mostly an artifact of the internal
+-- implementation, which uses type classes to generate the code for
+-- each pass of the algorithm. Therefore, the recommended way to learn
+-- how to use 'run' is to look at some of the examples in the
+-- @Example@ sub-directory.
+run
+  :: forall r w f f' g tc gc out.
+     ( InstantiatePasses f f'
+     , MultiPassAlgorithm (f' tc) g
+     , ApplyArgs r w g tc gc tc gc tc
+                 (MultiPassMain r w tc (Off out))
+     , InitCtx tc
+     , InitCtx gc
+     , RunPasses r w f tc gc Off out
+     )
+  => f
+  -> ST2 r w out
+run f =
+  let tc = initCtx :: tc in
+  let gc = initCtx :: gc in
+  do e <- runPasses (PassNumber 0) f Off tc gc
+     case e of
+       Left _
+         -> -- This is impossible, because it would imply that the
+            -- back-tracking mechanism is attempting to back-track to
+            -- a negative PassNumber.
+            assert False $ error "run"
+
+       Right result
+         -> return result
+
+-- | 'NumThreads' is used to specify the number of threads in
+-- 'parallelMP' and 'parallelMP_'.
+newtype NumThreads
+  = NumThreads Int
+
+-- | Use @m@ threads to run @n@ instances of the function @f@. The
+-- results are returned in an array of length @n@.
+parallelMP
+  :: (Ix i, Num i)
+  => NumThreads                 -- ^ Number of threads to spawn
+  -> (i,i)                      -- ^ Element range
+  -> (i -> MultiPass r w tc a)
+  -> MultiPass r w tc (ST2Array r w i a)
+parallelMP (NumThreads m) bnds f =
+  let n = rangeSize bnds in
+  assert (m > 0) $
+  if m == 1 || n <= 1
+     then -- Do not use parallelism.
+          do xs <- MultiPass $ MultiPassBase $ lift $ newST2Array_ bnds
+             sequence_
+               [ do x <- f i
+                    MultiPass $ MultiPassBase $ lift $
+                      writeST2Array xs i x
+               | i <- range bnds
+               ]
+             return xs
+     else assert (m > 1) $
+          assert (n > 1) $
+          parallelHelper (min m n) n bnds f
+
+parallelHelper
+  :: (Ix i, Num i)
+  => Int                        -- Number of threads
+  -> Int                        -- Number of elements
+  -> (i,i)                      -- Element range
+  -> (i -> MultiPass r w tc a)
+  -> MultiPass r w tc (ST2Array r w i a)
+parallelHelper m n bnds f =
+  MultiPass $ MultiPassBase $
+  do tc <- get
+     -- Split the thread state into m sub-states.
+     let tBnds = (0,m-1)
+     tcs <- lift $ newST2Array_ tBnds
+     lift $ sequence_
+       [ do tci <- splitThreadContext m t tc
+            writeST2Array tcs t tci
+       | t <- range tBnds
+       ]
+     -- Create an array for the results.
+     xs <- lift $ newST2Array_ bnds
+     let base = fst bnds
+     let blockSize = (n+m-1) `div` m
+     lift $ parallelST2 tBnds $ \i ->
+       do tci <- readST2Array tcs i
+          let start = i * blockSize
+          let end = min n (start + blockSize)
+          tci' <-
+            flip execStateT tci $
+            sequence_
+              [ let j' = base + fromIntegral j in
+                do x <- unwrapMultiPassBase $ unwrapMultiPass $ f j'
+                   lift $ writeST2Array xs j' x
+              | j <- [start .. end-1]
+              ]
+          writeST2Array tcs i tci'
+     -- Create the new merged state.
+     tc' <- lift $ mergeThreadContext m (readST2Array tcs) tc
+     put tc'
+     return xs
+
+-- | Modified version of 'parallelMP' which discards the result of the
+-- function, rather than writing it to an array.
+parallelMP_
+  :: (Ix i, Num i)
+  => NumThreads                 -- ^ Number of threads to spawn
+  -> (i,i)                      -- ^ Element range
+  -> (i -> MultiPass r w tc a)
+  -> MultiPass r w tc ()
+parallelMP_ (NumThreads m) bnds f =
+  let n = rangeSize bnds in
+  assert (m > 0) $
+  if m == 1 || n <= 1
+     then -- Do not use parallelism.
+          sequence_ [ f i | i <- range bnds ]
+     else assert (m > 1) $
+          assert (n > 1) $
+          parallelHelper_ (min m n) n bnds f
+
+parallelHelper_
+  :: (Ix i, Num i)
+  => Int                        -- Number of threads
+  -> Int                        -- Number of elements
+  -> (i,i)                      -- Element range
+  -> (i -> MultiPass r w tc a)
+  -> MultiPass r w tc ()
+parallelHelper_ m n bnds f =
+  MultiPass $ MultiPassBase $
+  do tc <- get
+     -- Split the thread state into m sub-states.
+     let tBnds = (0,m-1)
+     tcs <- lift $ newST2Array_ tBnds
+     lift $ sequence_
+       [ do tci <- splitThreadContext m t tc
+            writeST2Array tcs t tci
+       | t <- range tBnds
+       ]
+     let base = fst bnds
+     let blockSize = (n+m-1) `div` m
+     lift $ parallelST2 tBnds $ \i ->
+       do tci <- readST2Array tcs i
+          let start = i * blockSize
+          let end = min n (start + blockSize)
+          tci' <-
+            flip execStateT tci $
+            sequence_
+              [ let j' = base + fromIntegral j in
+                unwrapMultiPassBase $ unwrapMultiPass $ f j'
+              | j <- [start .. end-1]
+              ]
+          writeST2Array tcs i tci'
+     -- Create the new merged state.
+     tc' <- lift $ mergeThreadContext m (readST2Array tcs) tc
+     put tc'
+
+-- | Read-only ST2 computations are allowed to be executed in the
+-- MultiPass monad.
+readOnlyST2ToMP :: (forall w. ST2 r w a) -> MultiPass r w' tc a
+readOnlyST2ToMP m =
+  MultiPass $ MultiPassBase $
+  lift m
diff --git a/src/Control/Monad/MultiPass/Example/Assembler.hs b/src/Control/Monad/MultiPass/Example/Assembler.hs
new file mode 100644
--- /dev/null
+++ b/src/Control/Monad/MultiPass/Example/Assembler.hs
@@ -0,0 +1,200 @@
+-- Copyright 2013 Kevin Backhouse.
+
+module Control.Monad.MultiPass.Example.Assembler
+  ( LabelName(..), Register(..), Instruction(..)
+  , assemble
+  )
+where
+
+import Control.Exception ( assert )
+import Control.Monad ( liftM )
+import Control.Monad.ST2
+import Control.Monad.MultiPass
+import Control.Monad.MultiPass.Utils
+import Control.Monad.MultiPass.Instrument.Delay
+import Control.Monad.MultiPass.Instrument.EmitST2ArrayFxp
+import Control.Monad.MultiPass.Instrument.Monoid2
+import qualified Data.Map as FM
+import Data.Maybe ( fromJust )
+import Data.Ix
+import Data.Word
+import Data.Bits
+import Data.Monoid
+
+newtype LabelName
+  = LabelName String
+    deriving (Eq,Ord)
+
+instance Show LabelName where
+  show (LabelName name) = name
+
+newtype Register
+  = Register Int
+
+instance Show Register where
+  show (Register k) = "r" ++ show k
+
+data Instruction
+  = Label LabelName
+  | Goto LabelName
+  | AddImm8 Register Word8
+    deriving Show
+
+newtype Addr
+  = Addr Word64
+    deriving (Eq,Ord,Ix)
+
+instance Num Addr where
+  (Addr x) + (Addr y) = Addr (x + y)
+  (Addr x) - (Addr y) = Addr (x - y)
+  (Addr x) * (Addr y) = Addr (x * y)
+  negate (Addr x) = Addr (negate x)
+  abs (Addr x) = Addr (abs x)
+  signum (Addr x) = Addr (signum x)
+  fromInteger x = Addr (fromInteger x)
+
+instance Show Addr where
+  show (Addr x) = show x
+
+newtype LabelMap
+  = LabelMap (FM.Map LabelName Addr)
+
+lookupLabel :: LabelMap -> LabelName -> Addr
+lookupLabel (LabelMap table) key =
+  assert (FM.member key table) $
+  fromJust (FM.lookup key table)
+
+singletonLabelMap :: LabelName -> Addr -> LabelMap
+singletonLabelMap key val =
+  LabelMap $ FM.singleton key val
+
+instance Monoid LabelMap where
+  mempty =
+    LabelMap FM.empty
+
+  mappend (LabelMap xs) (LabelMap ys) =
+    assert (FM.null (FM.intersection xs ys)) $
+    LabelMap (FM.union xs ys)
+
+type EmitInstrsType r w p1 p2 p3 tc
+  =  EmitST2ArrayFxp Addr Word8 r w p1 p2 p3 tc
+  -> Monoid2 LabelMap r w p2 p3 tc
+  -> Delay p2 p3 tc
+  -> MultiPassMain r w tc (p3 (ST2Array r w Addr Word8))
+
+newtype EmitInstrs r w p1 p2 p3 tc =
+  EmitInstrs (EmitInstrsType r w p1 p2 p3 tc)
+
+instance MultiPassAlgorithm
+           (EmitInstrs r w p1 p2 p3 tc)
+           (EmitInstrsType r w p1 p2 p3 tc)
+           where
+  unwrapMultiPassAlgorithm (EmitInstrs f) = f
+
+assemble
+  :: NumThreads
+  -> ST2Array r w Int Instruction
+  -> ST2 r w (ST2Array r w Addr Word8)
+assemble nThreads instructions =
+  run $ PassS $ PassS $ PassS $ PassZ $
+  EmitInstrs $ \emitter labelMap delay12 ->
+  mkMultiPassMain
+    (return ())
+    (\() ->
+     mapST2ArrayMP_ nThreads instructions $
+       emitInstr emitter labelMap delay12)
+    (\() -> getResult emitter)
+
+emitInstr
+  :: (Monad p1, Monad p2, Monad p3)
+  => EmitST2ArrayFxp Addr Word8 r w p1 p2 p3 tc
+  -> Monoid2 LabelMap r w p2 p3 tc
+  -> Delay p2 p3 tc
+  -> Instruction
+  -> MultiPass r w tc ()
+emitInstr emitter labelMap delay12 instruction =
+  case instruction of
+    AddImm8 r k
+      -> emitList emitter (return 4) $
+         let r' = emitRegister r in
+         return $
+           encodeOpcodeWithREX 1 0x83 3 0 r' ++ [k]
+
+    Label label
+      -> do addr <- getIndex emitter
+            tell labelMap $ liftM (singletonLabelMap label) addr
+
+    Goto label
+      -> do pCurrAddr <- getIndex emitter
+            pLabels <- listen labelMap
+            emitList emitter (return 2) $
+              do currAddr <- delay delay12 pCurrAddr
+                 labels <- pLabels
+                 let gotoAddr = lookupLabel labels label
+                 -- The 2-byte JMP instruction can only be used if the
+                 -- relative offset can be represented as a signed
+                 -- 8-bit number. Note that the offset is calculated
+                 -- from the start of the next instruction, so
+                 -- currAddr needs to be incremented by 2 for this
+                 -- case.
+                 let Addr offset = gotoAddr - (currAddr + 2)
+                 return $
+                   if fitsSignedInt8 offset
+                      then [0xEB, fromIntegral offset]
+                      else -- Emit a 5-byte instruction. The offset
+                           -- needs to be updated accordingly.
+                           0xE9 : emitInt32 (offset - 3)
+
+-- Encode the first three bytes of an instruction with a REX prefix:
+--
+--   1. REX prefix
+--   2. Instruction opcode
+--   3. ModR/M byte
+--
+encodeOpcodeWithREX
+  :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> [Word8]
+encodeOpcodeWithREX w opcode md reg rm =
+  assert (w < 2) $
+  assert (md < 4) $
+  assert (reg < 16) $
+  assert (rm < 16) $
+  [ -- REX prefix
+    0x40 .|. shiftL w 3 .|.
+    shiftR (reg .&. 8) 1 .|. shiftR (rm .&. 8) 3
+
+  , opcode
+
+    -- ModR/M byte
+  , shiftL md 6 .|. shiftL (reg .&. 7) 3 .|. (rm .&. 7)
+  ]
+
+emitInt32 :: (Integral w, Bits w) => w -> [Word8]
+emitInt32 = emitWord 4
+
+-- Emit lowest n bytes of x, with the least significant byte at the
+-- head of the list.
+emitWord
+  :: (Integral w, Bits w)
+  => Int
+  -> w
+  -> [Word8]
+emitWord n x =
+  if n == 0
+     then []
+     else fromIntegral x : emitWord (n-1) (x `shiftR` 8)
+
+-- Convert the register to its 4-bit encoding.
+emitRegister :: Register -> Word8
+emitRegister (Register r) = fromIntegral r
+
+-- Return true if the number is representable as an Int8. 
+fitsSignedInt8 :: Integral w => w -> Bool
+fitsSignedInt8 k =
+  k == signExtend8 (fromIntegral k)
+
+-- Sign extend a Word8.
+signExtend8 :: Num w => Word8 -> w
+signExtend8 x =
+  if x .&. 0x80 == 0
+     then fromIntegral x
+     else -(fromIntegral (-x))
diff --git a/src/Control/Monad/MultiPass/Example/CFG.hs b/src/Control/Monad/MultiPass/Example/CFG.hs
new file mode 100644
--- /dev/null
+++ b/src/Control/Monad/MultiPass/Example/CFG.hs
@@ -0,0 +1,113 @@
+-- Copyright 2013 Kevin Backhouse.
+
+{-|
+This example is a variation on the
+'Control.Monad.MultiPass.Example.Assembler.assembler' example.  It
+illustrates how one might convert a control flow graph into a linear
+sequence of instructions. The example is less complete than the
+'Control.Monad.MultiPass.Example.Assembler.assembler' example, so the
+output is not real machine code. Instead the output is a simple
+serialised representation of the control flow graph.
+
+In this example, the control flow graph is represented as a
+'Data.Array.Array', which is an immutable datatype. The example can
+also be implemented with a mutable representation of the control flow
+graph, as shown in "Control.Monad.MultiPass.Example.CFG2".
+-}
+
+module Control.Monad.MultiPass.Example.CFG ( Node(..), emitCFG )
+where
+
+import Control.Monad.ST2
+import Control.Monad.MultiPass
+import Control.Monad.MultiPass.Instrument.EmitST2Array
+import Control.Monad.MultiPass.Instrument.Knot3
+import Control.Monad.MultiPass.Instrument.Delay
+import Control.Monad.MultiPass.Utils
+import Data.Array
+
+type CFG = Array Node [Node]
+
+newtype Node
+  = Node Int
+    deriving (Eq, Ord, Ix)
+
+newtype Position
+  = Position Int
+    deriving (Eq, Ord, Ix)
+
+instance Num Position where
+  (Position x) + (Position y) = Position (x + y)
+  (Position x) - (Position y) = Position (x - y)
+  (Position x) * (Position y) = Position (x * y)
+  negate (Position x) = Position (negate x)
+  abs (Position x) = Position (abs x)
+  signum (Position x) = Position (signum x)
+  fromInteger x = Position (fromInteger x)
+
+type EmitCFGType r w p1 p2 p3 tc
+  =  Knot3 (Array Node Position) r w p1 p2 p3 tc
+  -> EmitST2Array Position Int r w p1 p2 p3 tc
+  -> Delay p2 p3 tc
+  -> MultiPassMain r w tc (p3 (ST2Array r w Position Int))
+
+newtype EmitCFG r w p1 p2 p3 tc =
+  EmitCFG (EmitCFGType r w p1 p2 p3 tc)
+
+instance MultiPassAlgorithm
+           (EmitCFG r w p1 p2 p3 tc)
+           (EmitCFGType r w p1 p2 p3 tc)
+           where
+  unwrapMultiPassAlgorithm (EmitCFG f) = f
+
+emitCFG :: CFG -> ST2 r w (ST2Array r w Position Int)
+emitCFG g =
+  run $ PassS $ PassS $ PassS $ PassZ $ EmitCFG $
+  emitMain g
+
+emitMain
+  :: (Monad p1, Monad p2, Monad p3)
+  => CFG
+  -> EmitCFGType r w p1 p2 p3 tc
+emitMain g kn emitter delay12 =
+  mkMultiPassMain
+    (return ())
+    (\() -> knot3 kn (emitNodes emitter delay12 g))
+    (\() -> getResult emitter)
+
+emitNodes
+  :: (Monad p1, Monad p2, Monad p3)
+  => EmitST2Array Position Int r w p1 p2 p3 tc
+  -> Delay p2 p3 tc
+  -> CFG
+  -> p3 (Array Node Position)
+  -> MultiPass r w tc (p2 (Array Node Position), ())
+emitNodes emitter delay12 g offsets =
+  do g' <- pmapM g (emitNode emitter delay12 offsets)
+     return (g', ())
+
+emitNode
+  :: (Monad p1, Monad p2, Monad p3)
+  => EmitST2Array Position Int r w p1 p2 p3 tc
+  -> Delay p2 p3 tc
+  -> p3 (Array Node Position)
+  -> [Node]
+  -> MultiPass r w tc (p2 Position)
+emitNode emitter delay12 offsets ys =
+  do -- Emit the number of edges.
+     emit emitter (return (length ys))
+     sequence_
+       [ do -- Emit a relative offset for each edge.
+            pos <- getIndex emitter
+            emit emitter $
+              do pos' <- delay delay12 pos
+                 offsets' <- offsets
+                 let offset = offsets' ! y
+                 return (positionDiff offset pos')
+       | y <- ys
+       ]
+     getIndex emitter
+
+positionDiff :: Position -> Position -> Int
+positionDiff (Position a) (Position b) =
+  a - b
diff --git a/src/Control/Monad/MultiPass/Example/CFG2.hs b/src/Control/Monad/MultiPass/Example/CFG2.hs
new file mode 100644
--- /dev/null
+++ b/src/Control/Monad/MultiPass/Example/CFG2.hs
@@ -0,0 +1,122 @@
+-- Copyright 2013 Kevin Backhouse.
+
+{-|
+This example is a modified version of the
+"Control.Monad.MultiPass.Example.CFG" example, which uses a mutable
+'ST2Array' to represent the control flow graph rather than an
+immutable 'Data.Array.Array'. This means that it is not possible to
+use 'Control.Monad.MultiPass.Utils.pmapM' to map over the array.
+Instead 'pmapST2ArrayMP' is used
+-}
+
+module Control.Monad.MultiPass.Example.CFG2 ( Node(..), emitCFG )
+where
+
+import Control.Monad.ST2
+import Control.Monad.MultiPass
+import Control.Monad.MultiPass.Instrument.EmitST2Array
+import Control.Monad.MultiPass.Instrument.Knot3
+import Control.Monad.MultiPass.Instrument.Delay
+import Control.Monad.MultiPass.Instrument.CreateST2Array
+import Control.Monad.MultiPass.Instrument.DelayedLift
+import Data.Ix
+
+type CFG r w = ST2Array r w Node [Node]
+
+newtype Node
+  = Node Int
+    deriving (Eq, Ord, Ix)
+
+instance Num Node where
+  (Node x) + (Node y) = Node (x + y)
+  (Node x) - (Node y) = Node (x - y)
+  (Node x) * (Node y) = Node (x * y)
+  negate (Node x) = Node (negate x)
+  abs (Node x) = Node (abs x)
+  signum (Node x) = Node (signum x)
+  fromInteger x = Node (fromInteger x)
+
+newtype Position
+  = Position Int
+    deriving (Eq, Ord, Ix)
+
+instance Num Position where
+  (Position x) + (Position y) = Position (x + y)
+  (Position x) - (Position y) = Position (x - y)
+  (Position x) * (Position y) = Position (x * y)
+  negate (Position x) = Position (negate x)
+  abs (Position x) = Position (abs x)
+  signum (Position x) = Position (signum x)
+  fromInteger x = Position (fromInteger x)
+
+type EmitCFGType r w p1 p2 p3 tc
+  =  Knot3 (ST2Array r w Node Position) r w p1 p2 p3 tc
+  -> EmitST2Array Position Int r w p1 p2 p3 tc
+  -> Delay p2 p3 tc
+  -> DelayedLift r w p3 tc
+  -> CreateST2Array r w p2 tc
+  -> MultiPassMain r w tc (p3 (ST2Array r w Position Int))
+
+newtype EmitCFG r w p1 p2 p3 tc =
+  EmitCFG (EmitCFGType r w p1 p2 p3 tc)
+
+instance MultiPassAlgorithm
+           (EmitCFG r w p1 p2 p3 tc)
+           (EmitCFGType r w p1 p2 p3 tc)
+           where
+  unwrapMultiPassAlgorithm (EmitCFG f) = f
+
+emitCFG :: NumThreads -> CFG r w -> ST2 r w (ST2Array r w Position Int)
+emitCFG n g =
+  run $ PassS $ PassS $ PassS $ PassZ $ EmitCFG $
+  emitMain n g
+
+emitMain
+  :: (Monad p1, Monad p2, Monad p3)
+  => NumThreads
+  -> CFG r w
+  -> EmitCFGType r w p1 p2 p3 tc
+emitMain n g kn emitter delay12 dlift cr =
+  mkMultiPassMain
+    (return ())
+    (\() -> knot3 kn (emitNodes n emitter delay12 dlift cr g))
+    (\() -> getResult emitter)
+
+emitNodes
+  :: (Monad p1, Monad p2, Monad p3)
+  => NumThreads
+  -> EmitST2Array Position Int r w p1 p2 p3 tc
+  -> Delay p2 p3 tc
+  -> DelayedLift r w p3 tc
+  -> CreateST2Array r w p2 tc
+  -> CFG r w
+  -> p3 (ST2Array r w Node Position)
+  -> MultiPass r w tc (p2 (ST2Array r w Node Position), ())
+emitNodes n emitter delay12 dlift cr g offsets =
+  do g' <- pmapST2ArrayMP cr n g (emitNode emitter delay12 dlift offsets)
+     return (g', ())
+
+emitNode
+  :: (Monad p1, Monad p2, Monad p3)
+  => EmitST2Array Position Int r w p1 p2 p3 tc
+  -> Delay p2 p3 tc
+  -> DelayedLift r w p3 tc
+  -> p3 (ST2Array r w Node Position)
+  -> [Node]
+  -> MultiPass r w tc (p2 Position)
+emitNode emitter delay12 dlift offsets ys =
+  do emit emitter (return (length ys))
+     sequence_
+       [ do pos <- getIndex emitter
+            offset <- readST2ArrayMP dlift offsets y
+            emit emitter $
+              do pos' <- delay delay12 pos
+                 offset' <- offset
+                 return (positionDiff offset' pos')
+       | y <- ys
+       ]
+     getIndex emitter
+
+positionDiff :: Position -> Position -> Int
+positionDiff (Position a) (Position b) =
+  a - b
diff --git a/src/Control/Monad/MultiPass/Example/Counter.hs b/src/Control/Monad/MultiPass/Example/Counter.hs
new file mode 100644
--- /dev/null
+++ b/src/Control/Monad/MultiPass/Example/Counter.hs
@@ -0,0 +1,66 @@
+-- Copyright 2013 Kevin Backhouse.
+
+{-|
+An example of the use of the
+'Control.Monad.MultiPass.Instrument.Counter.Counter' instrument.
+-}
+
+module Control.Monad.MultiPass.Example.Counter
+  ( Tree(..), convertTree )
+where
+
+import Control.Monad.ST2
+import Control.Monad.MultiPass
+import Control.Monad.MultiPass.Instrument.CreateST2Array
+import Control.Monad.MultiPass.Instrument.Counter
+import Data.Ix
+
+newtype ConvertTree i a r w p1 p2 tc
+  = ConvertTree (ConvertTreeType i a r w p1 p2 tc)
+
+type ConvertTreeType i a r w p1 p2 tc
+  =  Counter i r w p1 p2 tc
+  -> CreateST2Array r w p2 tc
+  -> MultiPassMain r w tc (p2 (Tree r w i (i,a)))
+
+instance MultiPassAlgorithm
+           (ConvertTree i a r w p1 p2 tc)
+           (ConvertTreeType i a r w p1 p2 tc)
+           where
+  unwrapMultiPassAlgorithm (ConvertTree f) = f
+
+data Tree r w i a
+  = Node a (ST2Array r w i (Tree r w i a))
+
+convertTree
+  :: (Ix i, Num i)
+  => Tree r w i a
+  -> ST2 r w (Tree r w i (i,a))
+convertTree t =
+  run $ PassS $ PassS $ PassZ $ ConvertTree $ convertTreeMP t
+
+convertTreeMP
+  :: (Ix i, Num i, Monad p1, Monad p2)
+  => Tree r w i a
+  -> ConvertTreeType i a r w p1 p2 tc
+convertTreeMP t cnt cr =
+  mkMultiPassMain
+    (return ())
+    (\() -> convertSubTree t cnt cr)
+    return
+
+convertSubTree
+  :: (Ix i, Num i, Monad p1, Monad p2)
+  => Tree r w i a
+  -> Counter i r w p1 p2 tc
+  -> CreateST2Array r w p2 tc
+  -> MultiPass r w tc (p2 (Tree r w i (i,a)))
+convertSubTree (Node v xs) cnt cr =
+  do pk <- postIncr cnt
+     -- Use two threads to convert the children.
+     pxs <- pmapST2ArrayMP cr (NumThreads 2) xs $ \x ->
+              convertSubTree x cnt cr
+     return $
+       do k <- pk
+          xs' <- pxs
+          return (Node (k,v) xs')
diff --git a/src/Control/Monad/MultiPass/Example/Localmin.hs b/src/Control/Monad/MultiPass/Example/Localmin.hs
new file mode 100644
--- /dev/null
+++ b/src/Control/Monad/MultiPass/Example/Localmin.hs
@@ -0,0 +1,95 @@
+-- Copyright 2013 Kevin Backhouse.
+
+{-|
+A variation on the 'Control.Monad.MultiPass.Example.Repmin.repmin'
+example. This example shows how the
+'Control.Monad.MultiPass.Instrument.Knot3.Knot3' can be used in a
+recursive algorithm.
+-}
+
+module Control.Monad.MultiPass.Example.Localmin
+  ( Tree(..)
+  , localmin, localminMP
+  )
+where
+
+import Control.Monad ( liftM2 )
+import Control.Monad.ST2
+import Control.Monad.MultiPass
+import Control.Monad.MultiPass.Instrument.Knot3
+
+data Tree a
+  = Leaf !a
+  | Node !(Tree a) !(Tree a)
+    deriving (Eq, Show)
+
+-- | Version using lazy evaluation.
+localmin :: Ord a => Tree a -> Tree [a]
+localmin t =
+  snd (localminWalk [] t)
+
+localminWalk :: Ord a => [a] -> Tree a -> (a, Tree [a])
+localminWalk ns t =
+  case t of
+    Leaf n
+      -> (n, Leaf (n:ns))
+
+    Node t1 t2
+      -> let (n1,tr1) = localminWalk ns' t1
+             (n2,tr2) = localminWalk ns' t2
+             n = min n1 n2
+             ns' = n:ns
+         in
+         (n, Node tr1 tr2)
+
+type LocalminType r w a p1 p2 p3 tc
+  =  Knot3 a r w p1 p2 p3 tc
+  -> MultiPassMain r w tc (p3 (Tree [a]))
+
+newtype Localmin r w a p1 p2 p3 tc
+  = Localmin (LocalminType r w a p1 p2 p3 tc)
+
+instance MultiPassAlgorithm
+           (Localmin r w a p1 p2 p3 tc)
+           (LocalminType r w a p1 p2 p3 tc)
+           where
+  unwrapMultiPassAlgorithm (Localmin f) = f
+
+-- | Version using the "Control.Monad.MultiPass" library.
+localminMP :: Ord a => Tree a -> ST2 r w (Tree [a])
+localminMP t =
+  run (localminTopMP t)
+
+localminTopMP
+  :: Ord a
+  => Tree a
+  -> PassS (PassS (PassS PassZ)) (Localmin r w a)
+localminTopMP t =
+  PassS $ PassS $ PassS $ PassZ $ Localmin $ \kn ->
+  mkMultiPassMain
+    (return ())
+    (\() -> localminWalkMP kn t (return []))
+    (\(_,t') -> return t')
+
+localminWalkMP
+  :: (Ord a, Monad p1, Monad p2, Monad p3)
+  => Knot3 a r w p1 p2 p3 tc
+  -> Tree a
+  -> p3 [a]
+  -> MultiPass r w tc (p2 a, p3 (Tree [a]))
+localminWalkMP kn t ns =
+  case t of
+    Leaf n
+      -> return
+           ( return n
+           , do ns' <- ns
+                return (Leaf (n:ns'))
+           )
+
+    Node t1 t2
+      -> knot3 kn $ \n ->
+         let ns' = liftM2 (:) n ns in
+         do (n1,tr1) <- localminWalkMP kn t1 ns'
+            (n2,tr2) <- localminWalkMP kn t2 ns'
+            let n' = liftM2 min n1 n2
+            return (n', (n', liftM2 Node tr1 tr2))
diff --git a/src/Control/Monad/MultiPass/Example/OrdCons.hs b/src/Control/Monad/MultiPass/Example/OrdCons.hs
new file mode 100644
--- /dev/null
+++ b/src/Control/Monad/MultiPass/Example/OrdCons.hs
@@ -0,0 +1,51 @@
+-- Copyright 2013 Kevin Backhouse.
+
+{-|
+An example of the use of the
+'Control.Monad.MultiPass.Instrument.OrdCons.OrdCons' instrument.
+-}
+
+module Control.Monad.MultiPass.Example.OrdCons ( convertArray )
+where
+
+import Control.Monad.ST2
+import Control.Monad.MultiPass
+import Control.Monad.MultiPass.Instrument.CreateST2Array
+import Control.Monad.MultiPass.Instrument.OrdCons
+import Data.Ix
+
+newtype ConvertArray i a r w p1 p2 tc
+  = ConvertArray (ConvertArrayType i a r w p1 p2 tc)
+
+type ConvertArrayType i a r w p1 p2 tc
+  =  OrdCons a r w p1 p2 tc
+  -> CreateST2Array r w p2 tc
+  -> MultiPassMain r w tc (p2 (ST2Array r w i Int))
+
+instance MultiPassAlgorithm
+           (ConvertArray i a r w p1 p2 tc)
+           (ConvertArrayType i a r w p1 p2 tc)
+           where
+  unwrapMultiPassAlgorithm (ConvertArray f) = f
+
+convertArray
+  :: (Ix i, Num i, Ord a)
+  => NumThreads
+  -> ST2Array r w i a
+  -> ST2 r w (ST2Array r w i Int)
+convertArray n xs =
+  run $ PassS $ PassS $ PassZ $ ConvertArray $
+  convertArrayMP n xs
+
+convertArrayMP
+  :: (Ix i, Num i, Ord a, Monad p1, Monad p2)
+  => NumThreads
+  -> ST2Array r w i a
+  -> ConvertArrayType i a r w p1 p2 tc
+convertArrayMP n xs oc cr =
+  mkMultiPassMain
+    (return ())
+    (\() ->
+     pmapST2ArrayMP cr n xs $ \x ->
+       ordCons oc (return x))
+    return
diff --git a/src/Control/Monad/MultiPass/Example/Repmin.hs b/src/Control/Monad/MultiPass/Example/Repmin.hs
new file mode 100644
--- /dev/null
+++ b/src/Control/Monad/MultiPass/Example/Repmin.hs
@@ -0,0 +1,158 @@
+-- Copyright 2013 Kevin Backhouse.
+
+{-|
+An implementation of the classic @repmin@ algorithm, using the
+"Control.Monad.MultiPass" library.
+-}
+
+module Control.Monad.MultiPass.Example.Repmin
+  ( Tree(..)
+  , repmin, repminMP, repminMP2, repminMP3
+  )
+where
+
+import Control.Monad ( liftM, liftM2 )
+import Control.Monad.ST2
+import Control.Monad.MultiPass
+import Control.Monad.MultiPass.Instrument.Knot3
+import Control.Monad.MultiPass.Instrument.Monoid2
+import Control.Monad.MultiPass.Instrument.TopKnot
+import Data.Monoid
+
+-- | Binary tree datatype.
+data Tree a
+  = Leaf !a
+  | Node !(Tree a) !(Tree a)
+    deriving (Eq, Show)
+
+-- | Original algorithm, which uses lazy evaluation.
+repmin :: Ord a => Tree a -> Tree a
+repmin t =
+  let (minVal,tr) = repminWalk minVal t in
+  tr
+
+repminWalk :: Ord a => b -> Tree a -> (a, Tree b)
+repminWalk minVal t =
+  case t of
+    Leaf n
+      -> (n, Leaf minVal)
+
+    Node t1 t2
+      -> let (n1,tr1) = repminWalk minVal t1 in
+         let (n2,tr2) = repminWalk minVal t2 in
+         (min n1 n2, Node tr1 tr2)
+
+type RepminType r w a p1 p2 tc
+  =  TopKnot a r w p1 p2 tc
+  -> MultiPassMain r w tc (p2 (Tree a))
+
+newtype Repmin r w a p1 p2 tc
+  = Repmin (RepminType r w a p1 p2 tc)
+
+instance MultiPassAlgorithm
+           (Repmin r w a p1 p2 tc)
+           (RepminType r w a p1 p2 tc)
+           where
+  unwrapMultiPassAlgorithm (Repmin f) = f
+
+-- | New algorithm, using the "Control.Monad.MultiPass" library.
+repminMP :: Ord a => Tree a -> ST2 r w (Tree a)
+repminMP t =
+  run $ PassS $ PassS $ PassZ $ Repmin $ \kn ->
+  mkMultiPassMain
+    (load kn)
+    (repminWalkMP t)
+    (\(minVal,t') ->
+     do store kn minVal
+        return t')
+
+type RepminType2 r w a p1 p2 p3 tc
+  =  Knot3 a r w p1 p2 p3 tc
+  -> MultiPassMain r w tc (p3 (Tree a))
+
+newtype Repmin2 r w a p1 p2 p3 tc
+  = Repmin2 (RepminType2 r w a p1 p2 p3 tc)
+
+instance MultiPassAlgorithm
+           (Repmin2 r w a p1 p2 p3 tc)
+           (RepminType2 r w a p1 p2 p3 tc)
+           where
+  unwrapMultiPassAlgorithm (Repmin2 f) = f
+
+-- | Second version of the new algorithm ('repminMP'), using the
+-- 'Knot3' instrument, rather than 'TopKnot'.
+repminMP2 :: Ord a => Tree a -> ST2 r w (Tree a)
+repminMP2 t =
+  run $ PassS $ PassS $ PassS $ PassZ $ Repmin2 $ \kn ->
+  mkMultiPassMain
+    (return ())
+    (\() -> knot3 kn (repminWalkMP t))
+    return
+
+repminWalkMP
+  :: (Ord a, Monad p1, Monad p2)
+  => Tree a
+  -> p2 a
+  -> MultiPass r w tc (p1 a, p2 (Tree a))
+repminWalkMP t minVal =
+  case t of
+    Leaf n
+      -> return (return n, liftM Leaf minVal)
+
+    Node t1 t2
+      -> do (n1,tr1) <- repminWalkMP t1 minVal
+            (n2,tr2) <- repminWalkMP t2 minVal
+            return (liftM2 min n1 n2, liftM2 Node tr1 tr2)
+
+type RepminType3 r w a p1 p2 tc
+  =  Monoid2 (MinVal a) r w p1 p2 tc
+  -> MultiPassMain r w tc (p2 (Tree a))
+
+newtype Repmin3 r w a p1 p2 tc
+  = Repmin3 (RepminType3 r w a p1 p2 tc)
+
+instance MultiPassAlgorithm
+           (Repmin3 r w a p1 p2 tc)
+           (RepminType3 r w a p1 p2 tc)
+           where
+  unwrapMultiPassAlgorithm (Repmin3 f) = f
+
+-- | Third version of the new algorithm ('repminMP'), using the
+-- 'Monoid2' instrument.
+repminMP3 :: Ord a => Tree a -> ST2 r w (Tree a)
+repminMP3 t =
+  run $ PassS $ PassS $ PassZ $ Repmin3 $ \mv ->
+  mkMultiPassMain
+    (return ())
+    (\() -> repminWalkMP3 mv t)
+    return
+
+-- The purpose of this type is to define a Monoid instance with
+-- min as the mappend method.
+data MinVal a
+  = Infinity
+  | MinVal { getMinVal :: !a }
+
+instance Ord a => Monoid (MinVal a) where
+  mempty = Infinity
+
+  mappend x Infinity = x
+  mappend Infinity y = y
+  mappend (MinVal x) (MinVal y) = MinVal (min x y)
+
+repminWalkMP3
+  :: (Ord a, Monad p1, Monad p2)
+  => Monoid2 (MinVal a) r w p1 p2 tc
+  -> Tree a
+  -> MultiPass r w tc (p2 (Tree a))
+repminWalkMP3 mv t =
+  case t of
+    Leaf n
+      -> do tell mv (return (MinVal n))
+            minVal <- listen mv
+            return (liftM (Leaf . getMinVal) minVal)
+
+    Node t1 t2
+      -> do tr1 <- repminWalkMP3 mv t1
+            tr2 <- repminWalkMP3 mv t2
+            return (liftM2 Node tr1 tr2)
diff --git a/src/Control/Monad/MultiPass/Example/StringInterning.hs b/src/Control/Monad/MultiPass/Example/StringInterning.hs
new file mode 100644
--- /dev/null
+++ b/src/Control/Monad/MultiPass/Example/StringInterning.hs
@@ -0,0 +1,58 @@
+-- Copyright 2013 Kevin Backhouse.
+
+{-|
+An example of the use of the
+'Control.Monad.MultiPass.Instrument.OrdCons.OrdCons' instrument.
+An array of strings is converted to an array of integer indices,
+with one index for each distinct string. This process is commonly
+known as "string interning".
+-}
+
+module Control.Monad.MultiPass.Example.StringInterning
+  ( internStringArray )
+where
+
+import Control.Monad ( liftM2 )
+import Control.Monad.ST2
+import Control.Monad.MultiPass
+import Control.Monad.MultiPass.Instrument.CreateST2Array
+import Control.Monad.MultiPass.Instrument.OrdCons
+
+newtype InternArray r w p1 p2 tc
+  = InternArray (InternArrayType r w p1 p2 tc)
+
+type InternArrayType r w p1 p2 tc
+  =  OrdCons String r w p1 p2 tc
+  -> CreateST2Array r w p2 tc
+  -> MultiPassMain r w tc
+       (p2 (ST2Array r w Int Int, OrdConsTable String))
+
+instance MultiPassAlgorithm
+           (InternArray r w p1 p2 tc)
+           (InternArrayType r w p1 p2 tc)
+           where
+  unwrapMultiPassAlgorithm (InternArray f) = f
+
+internStringArray
+  :: NumThreads
+  -> ST2Array r w Int String
+  -> ST2 r w (ST2Array r w Int Int, OrdConsTable String)
+internStringArray n xs =
+  run $ PassS $ PassS $ PassZ $ InternArray $ \pool cr ->
+  mkMultiPassMain
+    (return ())
+    (\() -> internStringArrayElems pool cr n xs)
+    (\xs' ->
+     do table <- getOrdConsTable pool
+        return (liftM2 (,) xs' table))
+
+internStringArrayElems
+  :: (Monad p1, Monad p2)
+  => OrdCons String r w p1 p2 tc
+  -> CreateST2Array r w p2 tc
+  -> NumThreads
+  -> ST2Array r w Int String
+  -> MultiPass r w tc (p2 (ST2Array r w Int Int))
+internStringArrayElems pool cr n xs =
+  pmapST2ArrayMP cr n xs $ \x ->
+    ordCons pool (return x)
diff --git a/src/Control/Monad/MultiPass/Instrument/Counter.hs b/src/Control/Monad/MultiPass/Instrument/Counter.hs
new file mode 100644
--- /dev/null
+++ b/src/Control/Monad/MultiPass/Instrument/Counter.hs
@@ -0,0 +1,114 @@
+-- Copyright 2013 Kevin Backhouse.
+
+{-# OPTIONS_GHC -XKindSignatures #-}
+
+{-|
+The 'Counter' instrument is used to generate an increasing
+sequence of integers. It is particularly useful when the program
+uses parallelism, because the 'Counter' instrument creates the
+illusion of a single-threaded global counter. The first pass
+counts how many unique integers each thread needs so that the
+integers can be generated without the use of locks during the
+second pass.
+-}
+
+module Control.Monad.MultiPass.Instrument.Counter
+  ( Counter
+  , peek, addk, incr, preIncr, postIncr
+  )
+where
+
+import Control.Monad ( void )
+import Control.Monad.MultiPass
+import Control.Monad.MultiPass.ThreadContext.CounterTC
+
+-- | Abstract datatype for the instrument.
+data Counter i r w (p1 :: * -> *) p2 tc
+  = Counter
+      { peekInternal :: !(MultiPass r w tc (p2 i))
+      , addkInternal :: !(p1 i -> MultiPass r w tc ())
+      }
+
+-- | Get the current value of the counter.
+peek
+  :: (Num i, Monad p1, Monad p2)
+  => Counter i r w p1 p2 tc
+  -> MultiPass r w tc (p2 i)
+peek =
+  peekInternal
+
+-- | Add @k@ to the counter.
+addk
+  :: (Num i, Monad p1, Monad p2)
+  => Counter i r w p1 p2 tc        -- ^ counter
+  -> p1 i                          -- ^ k
+  -> MultiPass r w tc ()
+addk =
+  addkInternal
+
+-- | Increment the counter.
+incr
+  :: (Num i, Monad p1, Monad p2)
+  => Counter i r w p1 p2 tc
+  -> MultiPass r w tc ()
+incr c = addk c (return 1)
+
+-- | Read and pre-increment the counter. For example, if the current
+-- value is 17 then 'preIncr' updates the value of the counter to 18
+-- and returns 18.
+preIncr
+  :: (Num i, Monad p1, Monad p2)
+  => Counter i r w p1 p2 tc
+  -> MultiPass r w tc (p2 i)
+preIncr c =
+  do incr c
+     peek c
+
+-- | Read and post-increment the counter. For example, if the current
+-- value is 17 then 'postIncr' updates the value of the counter to 18
+-- and returns 17.
+postIncr
+  :: (Num i, Monad p1, Monad p2)
+  => Counter i r w p1 p2 tc
+  -> MultiPass r w tc (p2 i)
+postIncr c =
+  do v <- peek c
+     incr c
+     return v
+
+instance Instrument tc () () (Counter i r w Off Off tc) where
+  createInstrument _ _ () =
+    wrapInstrument $ Counter
+      { peekInternal = return Off
+      , addkInternal = \Off -> return ()
+      }
+
+-- Pass 1 of the Counter. This pass tracks the number of integers
+-- that are requested in each thread. At the end of the first pass,
+-- cumsum is used to assign disjoint ranges of integers to each
+-- thread.
+instance Num i =>
+         Instrument tc (CounterTC1 i r) ()
+                    (Counter i r w On Off tc) where
+  createInstrument _ updateCtx () =
+    wrapInstrument $ Counter
+      { peekInternal = return Off
+
+      , addkInternal = \(On k) ->
+          void $ mkMultiPass $ updateCtx $ addkCounterTC1 k
+      }
+
+-- Pass 2 of the Counter. The array has one counter per thread.
+instance Num i =>
+         Instrument tc (CounterTC2 i r) ()
+                    (Counter i r w On On tc) where
+  createInstrument _ updateCtx () =
+    wrapInstrument $ Counter
+      { peekInternal =
+          mkMultiPass $
+          do counter <- updateCtx id
+             return (On (counterVal2 counter))
+
+      , addkInternal = \(On k) ->
+          void $ mkMultiPass $ updateCtx $ addkCounterTC2 k
+      }
diff --git a/src/Control/Monad/MultiPass/Instrument/CreateST2Array.hs b/src/Control/Monad/MultiPass/Instrument/CreateST2Array.hs
new file mode 100644
--- /dev/null
+++ b/src/Control/Monad/MultiPass/Instrument/CreateST2Array.hs
@@ -0,0 +1,78 @@
+-- Copyright 2013 Kevin Backhouse.
+
+{-|
+The 'CreateST2Array' instrument is stateless and provides a similar
+interface to 'parallelMP'. The difference is that it produces the
+new array in a specific pass.
+-}
+
+module Control.Monad.MultiPass.Instrument.CreateST2Array
+  ( CreateST2Array
+  , createST2Array, pmapST2ArrayMP
+  )
+where
+
+import Control.Monad.ST2
+import Control.Monad.MultiPass
+import Data.Ix
+
+-- | Abstract datatype for the instrument.
+data CreateST2Array r w p1 tc
+  = CreateST2Array
+      { createInternal :: !(
+          forall i a.
+          (Ix i, Num i) =>
+          NumThreads ->        -- Number of threads to spawn
+          (i,i) ->             -- Element range
+          (i -> MultiPass r w tc (p1 a)) ->
+          MultiPass r w tc (p1 (ST2Array r w i a)))
+      }
+
+-- | Create a new array during pass @p1@, using the initialisation
+-- function to initialise the elements. The initialisation is done in
+-- parallel, using the specified number of threads.
+createST2Array
+  :: (Ix i, Num i, Monad p1)
+  => CreateST2Array r w p1 tc        -- ^ 'CreateST2Array' instrument
+  -> NumThreads                      -- ^ Number of threads to spawn
+  -> (i,i)                           -- ^ Element range
+  -> (i -> MultiPass r w tc (p1 a))  -- ^ Initialisation function
+  -> MultiPass r w tc (p1 (ST2Array r w i a)) -- ^ New array
+createST2Array =
+  createInternal
+
+instance Instrument tc () () (CreateST2Array r w Off tc) where
+  createInstrument _ _ () =
+    wrapInstrument $ CreateST2Array $ \m n f ->
+    do parallelMP_ m n f
+       return Off
+
+instance Instrument tc () () (CreateST2Array r w On tc) where
+  createInstrument _ _ () =
+    wrapInstrument $ CreateST2Array $ \m n f ->
+    let f' i =
+          do On x <- f i
+             return x
+    in
+    do xs <- parallelMP m n f'
+       return (On xs)
+
+-- | 'pmapST2ArrayMP' is a simple application of 'createST2Array'.  It
+-- provides a similar interface to
+-- 'Control.Monad.MultiPass.Utils.mapST2ArrayMP'. The difference is
+-- that it only executes the map operation once the specified pass is
+-- reached.
+pmapST2ArrayMP
+  :: (Ix i, Num i, Monad p1)
+  => CreateST2Array r w p1 tc       -- ^ 'CreateST2Array' instrument
+  -> NumThreads                     -- ^ Number of threads to spawn
+  -> ST2Array r w i a               -- ^ Input array
+  -> (a -> MultiPass r w tc (p1 b)) -- ^ Function to apply to each element
+  -> MultiPass r w tc (p1 (ST2Array r w i b)) -- ^ Output array
+pmapST2ArrayMP cr nThreads xs f =
+  let f' i =
+         do x <- readOnlyST2ToMP $ readST2Array xs i
+            f x
+  in
+  do bnds <- readOnlyST2ToMP $ boundsST2Array xs
+     createST2Array cr nThreads bnds f'
diff --git a/src/Control/Monad/MultiPass/Instrument/Delay.hs b/src/Control/Monad/MultiPass/Instrument/Delay.hs
new file mode 100644
--- /dev/null
+++ b/src/Control/Monad/MultiPass/Instrument/Delay.hs
@@ -0,0 +1,39 @@
+-- Copyright 2013 Kevin Backhouse.
+
+{-# OPTIONS_GHC -XKindSignatures #-}
+
+{-|
+The 'Delay' instrument is stateless and its implementation is trivial.
+Its purpose is to allow values which were computed in pass @p1@ to be
+used in pass @p2@.
+-}
+
+module Control.Monad.MultiPass.Instrument.Delay
+  ( Delay
+  , delay
+  )
+where
+
+import Control.Monad.MultiPass
+
+-- | Abstract datatype for the instrument.
+data Delay p1 p2 (tc :: *)
+  = Delay { delayInternal :: !(forall (a :: *). p1 a -> p2 a) }
+
+-- | 'delay' enables a value which was computed in pass @p1@ to be
+-- used in pass @p2@.
+delay :: Delay p1 p2 tc -> p1 a -> p2 a
+delay =
+  delayInternal
+
+instance Instrument tc () () (Delay Off Off tc) where
+  createInstrument _ _ () =
+    wrapInstrument $ Delay $ \Off -> Off
+
+instance Instrument tc () () (Delay On Off tc) where
+  createInstrument _ _ () =
+    wrapInstrument $ Delay $ \(On _) -> Off
+
+instance Instrument tc () () (Delay On On tc) where
+  createInstrument _ _ () =
+    wrapInstrument $ Delay $ id
diff --git a/src/Control/Monad/MultiPass/Instrument/DelayedLift.hs b/src/Control/Monad/MultiPass/Instrument/DelayedLift.hs
new file mode 100644
--- /dev/null
+++ b/src/Control/Monad/MultiPass/Instrument/DelayedLift.hs
@@ -0,0 +1,61 @@
+-- Copyright 2013 Kevin Backhouse.
+
+{-|
+The 'DelayedLift' instrument is stateless and provides a similar
+interface to 'readOnlyST2ToMP'. The difference is that it only
+executes the read-only computation once the specified pass is reached.
+-}
+
+module Control.Monad.MultiPass.Instrument.DelayedLift
+  ( DelayedLift
+  , delayedLift, readST2ArrayMP
+  )
+where
+
+import Control.Monad.ST2
+import Control.Monad.MultiPass
+import Data.Ix
+
+-- | Abstract datatype for the instrument.
+data DelayedLift r w p1 tc
+  = DelayedLift
+      { delayedLiftInternal ::
+          !(forall a. p1 (ReadOnlyST2 r a) -> MultiPass r w tc (p1 a))
+      }
+
+-- | Execute the read-only computation during pass @p1@.
+delayedLift
+  :: Monad p1
+  => DelayedLift r w p1 tc
+  -> p1 (ReadOnlyST2 r a)
+  -> MultiPass r w tc (p1 a)
+delayedLift =
+  delayedLiftInternal
+
+instance Instrument tc () () (DelayedLift r w Off tc) where
+  createInstrument _ _ () =
+    wrapInstrument $ DelayedLift $ \Off ->
+    return Off
+
+instance Instrument tc () () (DelayedLift r w On tc) where
+  createInstrument st2ToMP _ () =
+    wrapInstrument $ DelayedLift $ \(On m) ->
+    do x <- mkMultiPass $ st2ToMP $ runReadOnlyST2 m
+       return (On x)
+
+-- | 'readST2ArrayMP' is a simple application of 'delayedLift'. It
+-- reads an index of the array during pass @p1@. This is particularly
+-- useful if the array does not exist in earlier passes, for example
+-- because it was created by the
+-- 'Control.Monad.MultiPass.Instrument.CreateST2Array.CreateST2Array'
+-- instrument.
+readST2ArrayMP
+  :: (Ix i, Monad p1)
+  => DelayedLift r w p1 tc
+  -> p1 (ST2Array r w i a)
+  -> i
+  -> MultiPass r w tc (p1 a)
+readST2ArrayMP dlift xs i =
+  delayedLift dlift $
+  do xs' <- xs
+     return (ReadOnlyST2 $ readST2Array xs' i)
diff --git a/src/Control/Monad/MultiPass/Instrument/EmitST2Array.hs b/src/Control/Monad/MultiPass/Instrument/EmitST2Array.hs
new file mode 100644
--- /dev/null
+++ b/src/Control/Monad/MultiPass/Instrument/EmitST2Array.hs
@@ -0,0 +1,258 @@
+-- Copyright 2013 Kevin Backhouse.
+
+{-|
+The 'EmitST2Array' instrument is used to emit a sequence of values to
+an 'ST2Array'. It has three passes. The first pass counts the number
+of elements that will be written. The second pass is optional: it
+enables the index values to be read before the actual values have been
+written. (If this pass is not needed then the second and third passes
+can be merged by coalescing the type variables for the second and
+third passes: @EmitST2Array p1 p2 p2@.) The third pass writes the
+values to the output array.
+-}
+
+module Control.Monad.MultiPass.Instrument.EmitST2Array
+  ( EmitST2Array
+  , setBaseIndex, emit, emitList, getIndex, getResult
+  )
+where
+
+import Control.Exception ( assert )
+import Control.Monad.ST2
+import Control.Monad.MultiPass
+import Control.Monad.MultiPass.ThreadContext.CounterTC
+import Data.Ix
+
+-- | Abstract datatype for the instrument.
+data EmitST2Array i a r w p1 p2 p3 tc
+  = EmitST2Array
+      { setBaseInternal :: !(p2 i -> MultiPassPrologue r w tc ())
+
+      , emitInternal :: !(p3 a -> MultiPass r w tc ())
+
+      , emitListInternal :: !(p1 Int -> p3 [a] -> MultiPass r w tc ())
+
+      , getIndexInternal :: !(forall w'. MultiPass r w' tc (p2 i))
+
+      , getResultInternal
+          :: !(MultiPassEpilogue r w tc (p3 (ST2Array r w i a)))
+      }
+
+-- | Initialise the base index of the output array. This method is
+-- optional: if it is not called then the base index defaults to zero.
+setBaseIndex
+  :: (Ix i, Num i, Monad p1, Monad p2, Monad p3)
+  => EmitST2Array i a r w p1 p2 p3 tc  -- ^ Instrument
+  -> p2 i                              -- ^ Base index
+  -> MultiPassPrologue r w tc ()
+setBaseIndex =
+  setBaseInternal
+
+-- | Write one element to the output array.
+emit
+  :: (Ix i, Num i, Monad p1, Monad p2, Monad p3)
+  => EmitST2Array i a r w p1 p2 p3 tc  -- ^ Instrument
+  -> p3 a                              -- ^ Value to emit
+  -> MultiPass r w tc ()
+emit =
+  emitInternal
+
+-- | Write a list of elements to the output array. The length of the
+-- list needs to be declared in the first pass so that the correct
+-- number of elements can be allocated.
+emitList
+  :: (Ix i, Num i, Monad p1, Monad p2, Monad p3)
+  => EmitST2Array i a r w p1 p2 p3 tc  -- ^ Instrument
+  -> p1 Int                            -- ^ Length of the list
+  -> p3 [a]                            -- ^ List of elements to emit
+  -> MultiPass r w tc ()
+emitList =
+  emitListInternal
+
+-- | Get the current index in the output array.
+getIndex
+  :: (Ix i, Num i, Monad p1, Monad p2, Monad p3)
+  => EmitST2Array i a r w p1 p2 p3 tc  -- ^ Instrument
+  -> MultiPass r w' tc (p2 i)          -- ^ Current index
+getIndex =
+  getIndexInternal
+
+-- | Get the output array.
+getResult
+  :: (Ix i, Num i, Monad p1, Monad p2, Monad p3)
+  => EmitST2Array i a r w p1 p2 p3 tc                 -- ^ Instrument
+  -> MultiPassEpilogue r w tc (p3 (ST2Array r w i a)) -- ^ Output array
+getResult =
+  getResultInternal
+
+newtype GC2 r w i
+  = GC2 { gc2_base :: ST2Ref r w i }  -- Base index of the output array
+
+data GC3 r w i a
+  = GC3
+      { gc3_base :: !(ST2Ref r w i)   -- Base index of the output array
+      , gc3_output_array :: !(ST2Array r w i a)  -- Output array
+      }
+
+instance Instrument tc () ()
+                    (EmitST2Array i a r w Off Off Off tc) where
+  createInstrument _ _ () =
+    wrapInstrument $
+    EmitST2Array
+      { setBaseInternal   = \Off -> return ()
+      , emitInternal      = \Off -> return ()
+      , emitListInternal  = \Off Off -> return ()
+      , getIndexInternal  = return Off
+      , getResultInternal = return Off
+      }
+
+instance Num i =>
+         Instrument tc (CounterTC1 i r) ()
+                    (EmitST2Array i a r w On Off Off tc) where
+  createInstrument _ updateCtx () =
+    wrapInstrument $
+    EmitST2Array
+      { setBaseInternal = \Off ->
+          return ()
+
+      , emitInternal = \Off ->
+          mkMultiPass $
+          do _ <- updateCtx incrCounterTC1
+             return ()
+
+      , emitListInternal = \(On n) Off ->
+          mkMultiPass $
+          do _ <- updateCtx (addkCounterTC1 (fromIntegral n))
+             return ()
+
+      , getIndexInternal =
+          return Off
+
+      , getResultInternal =
+          return Off
+      }
+
+-- Pass 2 is optional. It can be included between passes 1 and 3, to
+-- allow the getIndex method to be used before the values are written
+-- into the array.
+instance Num i =>
+         Instrument tc (CounterTC2 i r) (GC2 r w i)
+                    (EmitST2Array i a r w On On Off tc) where
+  createInstrument st2ToMP updateCtx gc =
+    wrapInstrument $
+    EmitST2Array
+      { setBaseInternal = \(On base) ->
+          mkMultiPassPrologue $
+          st2ToMP $ writeST2Ref (gc2_base gc) base
+
+      , emitInternal = \Off ->
+          mkMultiPass $
+          do _ <- updateCtx incrCounterTC2
+             return ()
+
+      , emitListInternal = \(On n) Off ->
+          mkMultiPass $
+          do _ <- updateCtx (addkCounterTC2 (fromIntegral n))
+             return ()
+
+      , getIndexInternal =
+          mkMultiPass $
+          do counter <- updateCtx id
+             base <- st2ToMP $ readST2Ref (gc2_base gc)
+             return (On (base + counterVal2 counter))
+
+      , getResultInternal =
+          return Off
+      }
+
+instance (Ix i, Num i) =>
+         Instrument tc (CounterTC2 i r) (GC3 r w i a)
+                    (EmitST2Array i a r w On On On tc) where
+  createInstrument st2ToMP updateCtx gc =
+    wrapInstrument $
+    EmitST2Array
+      { setBaseInternal = \(On base) ->
+          mkMultiPassPrologue $
+          st2ToMP $ writeST2Ref (gc3_base gc) base
+
+      , emitInternal = \(On x) ->
+          mkMultiPass $
+          do base <- st2ToMP $ readST2Ref (gc3_base gc)
+             counter <- updateCtx incrCounterTC2
+             let k = base + counterVal2 counter
+             let xs = gc3_output_array gc
+             st2ToMP $ writeST2Array xs k x
+
+      , emitListInternal = \(On n) (On ys) ->
+          assert (n == length ys) $
+          mkMultiPass $
+          do base <- st2ToMP $ readST2Ref (gc3_base gc)
+             counter <- updateCtx (addkCounterTC2 (fromIntegral n))
+             let k = base + counterVal2 counter
+             sequence_
+               [ let k' = k + fromIntegral i in
+                 let xs = gc3_output_array gc in
+                 st2ToMP $ writeST2Array xs k' y
+               | (i,y) <- zip [0 .. n-1] ys
+               ]
+
+      , getIndexInternal =
+          mkMultiPass $
+          do base <- st2ToMP $ readST2Ref (gc3_base gc)
+             counter <- updateCtx id
+             return (On (base + counterVal2 counter))
+
+      , getResultInternal =
+          return $ On $ gc3_output_array gc
+      }
+
+-- This instrument never needs to back-track.
+instance BackTrack r w (CounterTC2 i r) (GC2 r w i)
+instance BackTrack r w (CounterTC2 i r) (GC3 r w i a)
+
+instance Num i => NextGlobalContext r w tc () (GC2 r w i) where
+  nextGlobalContext _ _ _ () =
+    do base <- newST2Ref 0
+       return $ GC2
+         { gc2_base = base
+         }
+
+instance (Ix i, Num i) =>
+         NextGlobalContext r w (CounterTC1 i r) (GC2 r w i)
+                           (GC3 r w i a) where
+  nextGlobalContext _ _ counter gc =
+    do base <- readST2Ref (gc2_base gc)
+       let n = base + counterVal1 counter
+       xs <- newST2Array_ (base, n-1)
+       return $ GC3
+         { gc3_base = gc2_base gc
+         , gc3_output_array = xs
+         }
+
+instance NextGlobalContext r w tc (GC2 r w i) (GC2 r w i) where
+  nextGlobalContext _ _ _ gc =
+    return gc
+
+instance (Ix i, Num i) =>
+         NextGlobalContext r w (CounterTC2 i r) (GC2 r w i)
+                           (GC3 r w i a) where
+  nextGlobalContext _ _ counter gc =
+    do base <- readST2Ref (gc2_base gc)
+       let n = base + counterVal2 counter
+       xs <- newST2Array_ (base, n-1)
+       return $ GC3
+         { gc3_base = gc2_base gc
+         , gc3_output_array = xs
+         }
+
+instance NextGlobalContext r w (CounterTC2 i r)
+                           (GC3 r w i a) (GC3 r w i a)
+                           where
+  nextGlobalContext _ _ _ gc =
+    return gc
+
+instance NextGlobalContext r w (CounterTC2 i r)
+                           (GC3 r w i a) (GC2 r w i)
+                           where
+  nextGlobalContext _ _ _ gc =
+    return $ GC2 { gc2_base = gc3_base gc }
diff --git a/src/Control/Monad/MultiPass/Instrument/EmitST2ArrayFxp.hs b/src/Control/Monad/MultiPass/Instrument/EmitST2ArrayFxp.hs
new file mode 100644
--- /dev/null
+++ b/src/Control/Monad/MultiPass/Instrument/EmitST2ArrayFxp.hs
@@ -0,0 +1,545 @@
+-- Copyright 2013 Kevin Backhouse.
+
+{-|
+The 'EmitST2ArrayFxp' instrument has an identical interface to
+'Control.Monad.MultiPass.Instrument.EmitST2Array'. The only difference
+is that 'EmitST2ArrayFxp' includes support for back-tracking. The
+'emitList' method of 'EmitST2ArrayFxp' permits the list argument to be
+longer than the lower bound which was specified during the first
+pass. If it is then the algorithm will back-track to the beginning of
+the second pass and iterate until a fixed point has been reached.
+-}
+
+module Control.Monad.MultiPass.Instrument.EmitST2ArrayFxp
+  ( EmitST2ArrayFxp
+  , setBaseIndex, emit, emitList, getIndex, getResult
+  )
+where
+
+import Control.Exception ( assert )
+import Control.Monad.ST2
+import Control.Monad.Writer.Strict
+import Control.Monad.MultiPass
+import Control.Monad.MultiPass.Utils.UpdateCtx
+import Control.Monad.MultiPass.ThreadContext.CounterTC
+import Control.Monad.MultiPass.ThreadContext.MonoidTC
+import Data.Ix
+
+-- | Abstract datatype for the instrument.
+data EmitST2ArrayFxp i a r w p1 p2 p3 tc
+  = EmitST2ArrayFxp
+      { setBaseInternal :: !(p2 i -> MultiPassPrologue r w tc ())
+
+      , emitInternal :: !(p3 a -> MultiPass r w tc ())
+
+      , emitListInternal :: !(p1 Int -> p3 [a] -> MultiPass r w tc ())
+
+      , getIndexInternal :: !(forall w'. MultiPass r w' tc (p2 i))
+
+      , getResultInternal
+          :: !(MultiPassEpilogue r w tc (p3 (ST2Array r w i a)))
+      }
+
+-- | Initialise the base index of the output array. This method is
+-- optional: if it is not called then the base index defaults to zero.
+setBaseIndex
+  :: (Ix i, Num i, Monad p1, Monad p2, Monad p3)
+  => EmitST2ArrayFxp i a r w p1 p2 p3 tc  -- ^ Instrument
+  -> p2 i                                 -- ^ Base index
+  -> MultiPassPrologue r w tc ()
+setBaseIndex =
+  setBaseInternal
+
+-- | Write one element to the output array.
+emit
+  :: (Ix i, Num i, Monad p1, Monad p2, Monad p3)
+  => EmitST2ArrayFxp i a r w p1 p2 p3 tc  -- ^ Instrument
+  -> p3 a                                 -- ^ Value to emit
+  -> MultiPass r w tc ()
+emit =
+  emitInternal
+
+-- | Write a list of elements to the output array. The instrument uses
+-- back-tracking to iterate until the length of the list has been
+-- determined. It is the client's responsibility to ensure that any
+-- operations which depend on the length of the list are monotonic so
+-- that a fixed point will be found. The first argument is used to
+-- supply a minimum length for the list (zero is always a valid
+-- input). It can be used to shorten the time to convergence when a
+-- good lower bound is known.
+emitList
+  :: (Ix i, Num i, Monad p1, Monad p2, Monad p3)
+  => EmitST2ArrayFxp i a r w p1 p2 p3 tc  -- ^ Instrument
+  -> p1 Int                               -- ^ Length of the list
+  -> p3 [a]                               -- ^ List of elements to emit
+  -> MultiPass r w tc ()
+emitList =
+  emitListInternal
+
+-- | Get the current index in the output array.
+getIndex
+  :: (Ix i, Num i, Monad p1, Monad p2, Monad p3)
+  => EmitST2ArrayFxp i a r w p1 p2 p3 tc  -- ^ Instrument
+  -> MultiPass r w' tc (p2 i)             -- ^ Current index
+getIndex =
+  getIndexInternal
+
+-- | Get the output array.
+getResult
+  :: (Ix i, Num i, Monad p1, Monad p2, Monad p3)
+  => EmitST2ArrayFxp i a r w p1 p2 p3 tc              -- ^ Instrument
+  -> MultiPassEpilogue r w tc (p3 (ST2Array r w i a)) -- ^ Output array
+getResult =
+  getResultInternal
+
+instance Instrument tc () ()
+                    (EmitST2ArrayFxp i a r w Off Off Off tc) where
+  createInstrument _ _ () =
+    wrapInstrument $
+    EmitST2ArrayFxp
+      { setBaseInternal   = \Off -> return ()
+      , emitInternal      = \Off -> return ()
+      , emitListInternal  = \Off Off -> return ()
+      , getIndexInternal  = return Off
+      , getResultInternal = return Off
+      }
+
+-- Thread context for the first pass. One first counter is for the
+-- current index. The second counter is for the number of calls to
+-- emitList.
+type TC1 i r = (CounterTC1 i r, CounterTC1 ListIndex r)
+
+newtype ListIndex
+  = ListIndex Int
+    deriving (Eq,Ord,Ix)
+
+instance Num ListIndex where
+  (ListIndex x) + (ListIndex y) = ListIndex (x + y)
+  (ListIndex x) - (ListIndex y) = ListIndex (x - y)
+  (ListIndex x) * (ListIndex y) = ListIndex (x * y)
+  negate (ListIndex x) = ListIndex (negate x)
+  abs (ListIndex x) = ListIndex (abs x)
+  signum (ListIndex x) = ListIndex (signum x)
+  fromInteger x = ListIndex (fromInteger x)
+
+instance Show ListIndex where
+  show (ListIndex i) = show i
+
+instance Num i =>
+         Instrument tc (TC1 i r) ()
+                    (EmitST2ArrayFxp i a r w On Off Off tc) where
+  createInstrument _ updateCtx () =
+    wrapInstrument $
+    EmitST2ArrayFxp
+      { setBaseInternal = \Off ->
+          return ()
+
+      , emitInternal = \Off ->
+          mkMultiPass $
+          do _ <- updateCtxFst updateCtx incrCounterTC1
+             return ()
+
+      , emitListInternal = \(On lowerBound) Off ->
+          mkMultiPass $
+          do _ <- updateCtxFst updateCtx
+                    (addkCounterTC1 (fromIntegral lowerBound))
+             _ <- updateCtxSnd updateCtx incrCounterTC1
+             return ()
+
+      , getIndexInternal =
+          return Off
+
+      , getResultInternal =
+          return Off
+      }
+
+-- Thread context for the second pass. The fields correspond to the
+-- fields of TC1.
+type TC2 i r = (CounterTC2 i r, CounterTC2 ListIndex r)
+
+data GC2 r w i
+  = GC2 { -- Base index of the output array
+          gc2_base :: !(ST2Ref r w i)
+
+          -- The length array is uninitialised the first time the
+          -- pass is executed.
+        , gc2_initialised :: !Bool
+
+          -- Array of list lengths.
+        , gc2_length_array :: !(ST2Array r w ListIndex Int)
+
+          -- The pass number for the second pass.
+        , gc2_passnumber :: !PassNumber
+        }
+
+-- Pass 2 is optional. It can be included between passes 1 and 3, to
+-- allow the getIndexInternal method to be used before the values are
+-- written into the array.
+instance (Ix i, Num i) =>
+         Instrument tc (TC2 i r) (GC2 r w i)
+                    (EmitST2ArrayFxp i a r w On On Off tc) where
+  createInstrument st2ToMP updateCtx gc =
+    wrapInstrument $
+    EmitST2ArrayFxp
+      { setBaseInternal = \(On base) ->
+          mkMultiPassPrologue $
+          st2ToMP $ writeST2Ref (gc2_base gc) base
+
+      , emitInternal = \Off ->
+          void $ mkMultiPass $ updateCtxFst updateCtx incrCounterTC2
+
+      , emitListInternal =
+          -- The initialised field specifies whether the elements of
+          -- the length array have been initialised yet.
+          let lenArray = gc2_length_array gc in
+          if gc2_initialised gc then (
+            \(On lowerBound) Off ->
+            mkMultiPass $
+            do listCount <- updateCtxSnd updateCtx incrCounterTC2
+               let i = counterVal2 listCount
+               len <- st2ToMP $ readST2Array lenArray i
+               assert (lowerBound <= len) $ return ()
+               void $ updateCtxFst updateCtx $
+                      addkCounterTC2 (fromIntegral len)
+          ) else (
+            \(On lowerBound) Off ->
+            mkMultiPass $
+            do listCount <- updateCtxSnd updateCtx incrCounterTC2
+               let i = counterVal2 listCount
+               -- Initialise the length array with the lower bound.
+               st2ToMP $ writeST2Array lenArray i lowerBound
+               void $ updateCtxFst updateCtx $
+                      addkCounterTC2 (fromIntegral lowerBound)
+          )
+
+      , getIndexInternal =
+          mkMultiPass $
+          do base <- st2ToMP $ readST2Ref (gc2_base gc)
+             counter <- updateCtxFst updateCtx id
+             return (On (base + counterVal2 counter))
+
+      , getResultInternal =
+          return Off
+      }
+
+-- Thread context for the third pass. The indexCounter and listCounter
+-- fields correspond to the counters in the TC1 and TC2 thread
+-- contexts. The third field, newIndexCounter, will become the index
+-- counter if the algorithm back-tracks. The fourth field,
+-- indexChanged, tracks whether there are any differences between the
+-- new counter and the old.
+data TC3 i r
+  = TC3 { indexCounter    :: CounterTC2 i r
+        , listCounter     :: CounterTC2 ListIndex r
+        , newIndexCounter :: CounterTC1 i r
+        , indexChanged    :: MonoidTC Any
+        }
+
+updateIndexCounter
+  :: UpdateThreadContext rootTC (TC3 i r)
+  -> UpdateThreadContext rootTC (CounterTC2 i r)
+updateIndexCounter updateCtx f =
+  do tc <- updateCtx $ \tc ->
+             tc { indexCounter = f (indexCounter tc) }
+     return (indexCounter tc)
+
+updateListCounter
+  :: UpdateThreadContext rootTC (TC3 i r)
+  -> UpdateThreadContext rootTC (CounterTC2 ListIndex r)
+updateListCounter updateCtx f =
+  do tc <- updateCtx $ \tc ->
+             tc { listCounter = f (listCounter tc) }
+     return (listCounter tc)
+
+updateNewIndexCounter
+  :: UpdateThreadContext rootTC (TC3 i r)
+  -> UpdateThreadContext rootTC (CounterTC1 i r)
+updateNewIndexCounter updateCtx f =
+  do tc <- updateCtx $ \tc ->
+             tc { newIndexCounter = f (newIndexCounter tc) }
+     return (newIndexCounter tc)
+
+updateIndexChanged
+  :: UpdateThreadContext rootTC (TC3 i r)
+  -> UpdateThreadContext rootTC (MonoidTC Any)
+updateIndexChanged updateCtx f =
+  do tc <- updateCtx $ \tc ->
+             tc { indexChanged = f (indexChanged tc) }
+     return (indexChanged tc)
+
+instance Num i => ThreadContext r w (TC3 i r) where
+  splitThreadContext m t (TC3 a b c d) =
+    do a' <- splitThreadContext m t a
+       b' <- splitThreadContext m t b
+       c' <- splitThreadContext m t c
+       d' <- splitThreadContext m t d
+       return (TC3 a' b' c' d')
+
+  mergeThreadContext m getSubContext (TC3 a b c d) =
+    let getField f tc =
+          do tc' <- getSubContext tc
+             return (f tc')
+    in
+    do a' <- mergeThreadContext m (getField indexCounter) a
+       b' <- mergeThreadContext m (getField listCounter) b
+       c' <- mergeThreadContext m (getField newIndexCounter) c
+       d' <- mergeThreadContext m (getField indexChanged) d
+       return $ TC3
+         { indexCounter    = a'
+         , listCounter     = b'
+         , newIndexCounter = c'
+         , indexChanged    = d'
+         }
+
+data GC3 r w i a
+  = GC3 { -- Base index of the output array
+          gc3_base :: !(ST2Ref r w i)
+
+          -- Array of list lengths.
+        , gc3_length_array :: !(ST2Array r w ListIndex Int)
+
+          -- Output array. This array is not allocated until the
+          -- length array has reached a fixed point, so that its size
+          -- is known.
+        , gc3_output_array :: !(ST2Array r w i a)
+
+          -- This field is False until a fixed point has been reached.
+          -- It is used to indicate that the output array is ready to
+          -- be written. (When gc3_ready is False, the output array is
+          -- empty.)
+        , gc3_ready :: !Bool
+
+          -- The pass number for the second pass, unless the second
+          -- pass was skipped, in which case it is the pass number for
+          -- the third pass.
+        , gc3_passnumber2 :: !PassNumber
+
+          -- The pass number for the third pass.
+        , gc3_passnumber3 :: !PassNumber
+        }
+
+instance (Ix i, Num i) =>
+         Instrument tc (TC3 i r) (GC3 r w i a)
+                    (EmitST2ArrayFxp i a r w On On On tc) where
+  createInstrument st2ToMP updateCtx gc =
+    -- This function updates the indexCounter and newIndexCounter and
+    -- returns the current index.
+    let writeHelper =
+          do void $ updateNewIndexCounter updateCtx incrCounterTC1
+             base <- st2ToMP $ readST2Ref (gc3_base gc)
+             counter <-
+               updateIndexCounter updateCtx incrCounterTC2
+             return $ base + counterVal2 counter
+    in
+    -- This function updates the listCounter, indexCounter, and
+    -- newIndexCounter and checks whether a fixed point has been
+    -- reached. It returns the current index.
+    let writeListHelper lowerBound ys =
+          let newLen = length ys in
+          do -- Update the list length array and check whether the
+             -- length has increased since the last iteration.
+             listCount <-
+               updateListCounter updateCtx incrCounterTC2
+             let i = counterVal2 listCount
+             oldLen <- st2ToMP $ readST2Array (gc3_length_array gc) i
+             st2ToMP $ writeST2Array (gc3_length_array gc) i newLen
+             -- Update the indexChanged field.
+             assert (newLen >= lowerBound) $ return ()
+             assert (newLen >= oldLen) $ return ()
+             let changed = MonoidTC $ Any $ newLen /= oldLen
+             void $ updateIndexChanged updateCtx $ mappend changed
+             -- Update the newIndexCounter field with the new length.
+             void $ updateNewIndexCounter updateCtx
+                      (addkCounterTC1 (fromIntegral newLen))
+             -- Get the current count. The indexCounter field was
+             -- initialised with the old length, so it needs to be
+             -- used again here for consistency.
+             base <- st2ToMP $ readST2Ref (gc3_base gc)
+             indexCount <- updateIndexCounter updateCtx
+                             (addkCounterTC2 (fromIntegral oldLen))
+             return (base + counterVal2 indexCount)
+    in
+    let setBaseHelper (On base) =
+          mkMultiPassPrologue $
+          st2ToMP $ writeST2Ref (gc3_base gc) base
+    in
+    let getIndexHelper =
+          mkMultiPass $
+          do base <- st2ToMP $ readST2Ref (gc3_base gc)
+             indexCount <- updateIndexCounter updateCtx id
+             return (On (base + counterVal2 indexCount))
+    in
+    let xs = gc3_output_array gc in
+    let getResultHelper = return $ On $ xs in
+    -- The code below creates two different versions of the
+    -- instrument, depending on the value of gc3_ready. If gc3_ready
+    -- is false then no values are written to the output array because
+    -- it has not been allocated yet.
+    if gc3_ready gc then (
+      wrapInstrument $
+           EmitST2ArrayFxp
+           { setBaseInternal = setBaseHelper
+
+           , emitInternal = \(On x) ->
+               mkMultiPass $
+               do k <- writeHelper
+                  st2ToMP $ writeST2Array xs k x
+
+           , emitListInternal = \(On lowerBound) (On ys) ->
+               mkMultiPass $
+               do j <- writeListHelper lowerBound ys
+                  let n = length ys
+                  sequence_
+                    [ let j' = j + fromIntegral k in
+                      st2ToMP $ writeST2Array xs j' y
+                    | (k,y) <- zip [0 .. n-1] ys
+                    ]
+
+           , getIndexInternal = getIndexHelper
+           , getResultInternal = getResultHelper
+           }
+    ) else (
+      wrapInstrument $
+           EmitST2ArrayFxp
+           { setBaseInternal = setBaseHelper
+
+           , emitInternal = \(On _) ->
+               void $ mkMultiPass $ writeHelper
+
+           , emitListInternal = \(On lowerBound) (On ys) ->
+              void $ mkMultiPass $ writeListHelper lowerBound ys
+
+           , getIndexInternal = getIndexHelper
+           , getResultInternal = getResultHelper
+           }
+    )
+
+-- This instrument never needs to back-track after the second pass.
+instance BackTrack r w (TC2 i r) (GC2 r w i)
+
+instance BackTrack r w (TC3 i r) (GC3 r w i a) where
+  backtrack tc gc =
+    let MonoidTC (Any changed) = indexChanged tc in
+    case (changed, gc3_ready gc) of
+      (False, False)
+        -> -- A fixed point has been found, but the output array has
+           -- not been created yet, so the current pass needs to be
+           -- executed one more time.
+           return $ Just $ gc3_passnumber3 gc
+
+      (False, True)
+        -> -- A fixed point has already been found and the array has
+           -- already been allocated, so there is no need to
+           -- back-track.
+           return Nothing
+
+      (True, False)
+        -> -- A fixed point has not been found yet, so back-track to
+           -- the second pass.
+           return $ Just $ gc3_passnumber2 gc
+
+      (True, True)
+        -> -- A fixed point has not been found yet, so the array
+           -- should not have been allocated yet.
+           assert False $ return Nothing
+
+instance Num i =>
+         NextThreadContext r w (TC3 i r) gc (TC3 i r) where
+  nextThreadContext _ _ tc _ =
+    do -- Replace the old index counter with the new index counter.
+       indexCount <- newCounterTC2 (newIndexCounter tc)
+       return $ TC3
+         { indexCounter    = indexCount
+         , listCounter     = resetCounterTC2 (listCounter tc)
+         , newIndexCounter = newCounterTC1
+         , indexChanged    = mempty
+         }
+
+instance Num i =>
+         NextGlobalContext r w (TC1 i r) () (GC2 r w i) where
+  nextGlobalContext n _ (_,listCount) () =
+    do base <- newST2Ref 0
+       xs <- newST2Array_ (0, counterVal1 listCount - 1)
+       return $ GC2
+         { gc2_base         = base
+         , gc2_initialised  = False
+         , gc2_length_array = xs
+         , gc2_passnumber   = n
+         }
+
+instance NextGlobalContext r w (TC2 i r) (GC2 r w i) (GC2 r w i) where
+  nextGlobalContext _ _ _ gc =
+    return $ gc { gc2_initialised = True }
+
+instance (Ix i, Num i) =>
+         NextGlobalContext r w (TC2 i r) (GC2 r w i) (GC3 r w i a) where
+  nextGlobalContext n _ _ gc =
+    do -- Initialise the output array with a trivial array. (The
+       -- output array is not used when gc3_ready is False.)
+       xs <- newST2Array_ (0,0)
+       return $ GC3
+         { gc3_base         = gc2_base gc
+         , gc3_length_array = gc2_length_array gc
+         , gc3_output_array = xs
+         , gc3_ready        = False
+         , gc3_passnumber2  = gc2_passnumber gc
+         , gc3_passnumber3  = n
+         }
+
+instance (Ix i, Num i) =>
+         NextGlobalContext r w (TC3 i r)
+                           (GC3 r w i a) (GC3 r w i a) where
+  nextGlobalContext _ StepForward _ gc = return gc
+  nextGlobalContext _ StepBackward _ gc = return gc
+  nextGlobalContext _ StepReset tc gc =
+    let MonoidTC (Any changed) = indexChanged tc in
+    case (changed, gc3_ready gc) of
+      (False, False)
+        -> -- A fixed point has been found, so it is time to
+           -- allocate the array.
+           do base <- readST2Ref (gc3_base gc)
+              let n = base + counterVal2 (indexCounter tc)
+              xs <- newST2Array_ (base, n-1)
+              return $ gc
+                { gc3_output_array = xs
+                , gc3_ready        = True
+                }
+
+      (False, True)
+        -> -- A fixed point has already been found and the array has
+           -- already been allocated, so no change is needed.
+           return gc
+
+      (True, False)
+        -> -- A fixed point has not been found yet, so no change is
+           -- needed.
+           return gc
+
+      (True, True)
+        -> -- A fixed point has not been found yet, so the array
+           -- should not have been allocated yet.
+           assert False $ return gc
+
+instance NextGlobalContext r w (TC3 i r) (GC3 r w i a)
+                           (GC2 r w i) where
+  nextGlobalContext _ _ _ gc =
+    return $ GC2
+      { gc2_base         = gc3_base gc
+      , gc2_initialised  = True
+      , gc2_length_array = gc3_length_array gc
+      , gc2_passnumber   = gc3_passnumber2 gc
+      }
+
+instance Num i =>
+         NextThreadContext r w (TC2 i r) gc (TC3 i r) where
+  nextThreadContext _ _ (indexCount, listCount) _ =
+    return $ TC3
+      { indexCounter    = resetCounterTC2 indexCount
+      , listCounter     = resetCounterTC2 listCount
+      , newIndexCounter = newCounterTC1
+      , indexChanged    = mempty
+      }
+
+instance NextThreadContext r w (TC3 i r) gc (TC2 i r) where
+  nextThreadContext _ _ tc _ =
+    return (indexCounter tc, listCounter tc)
diff --git a/src/Control/Monad/MultiPass/Instrument/Knot3.hs b/src/Control/Monad/MultiPass/Instrument/Knot3.hs
new file mode 100644
--- /dev/null
+++ b/src/Control/Monad/MultiPass/Instrument/Knot3.hs
@@ -0,0 +1,98 @@
+-- Copyright 2013 Kevin Backhouse.
+
+{-# OPTIONS_GHC -XKindSignatures #-}
+
+{-|
+The 'Knot3' instrument is used for knot tying across passes. Knot
+tying is a technique sometimes used in lazy functional programming, in
+which the definition of a variable depends on its own value. The lazy
+programming technique depends on an implicit two-pass ordering of the
+computation. For example, the classic repmin program produces a pair
+of outputs - a tree and an integer - and there is an implicit two-pass
+ordering where the integer is computed during the first pass and the
+tree during the second. The 'Knot3' instrument allows the same
+technique to be applied, but the ordering of the passes is managed
+explicitly by the "Control.Monad.MultiPass" library, rather than
+implicitly by lazy evalution.
+-}
+
+module Control.Monad.MultiPass.Instrument.Knot3
+  ( Knot3
+  , knot3
+  )
+where
+
+import Control.Monad ( void )
+import Control.Monad.ST2
+import Control.Monad.MultiPass
+import Control.Monad.MultiPass.ThreadContext.CounterTC
+
+-- | Abstract datatype for the instrument.
+data Knot3 (a :: *) r w (p1 :: * -> *) p2 p3 tc
+  = Knot3
+      { knot3Internal :: !(forall b.
+          (p3 a -> MultiPass r w tc (p2 a, b)) -> MultiPass r w tc b)
+      }
+
+-- | Tie the knot for the supplied function.
+knot3
+  :: (Monad p1, Monad p2, Monad p3)
+  => Knot3 a r w p1 p2 p3 tc
+  -> (p3 a -> MultiPass r w tc (p2 a, b))
+  -> MultiPass r w tc b
+knot3 =
+  knot3Internal
+
+newtype Buffer r w a
+  = Buffer (ST2Array r w Int a)  -- Storage array
+
+instance Instrument tc () () (Knot3 a r w Off Off Off tc) where
+  createInstrument _ _ () =
+    wrapInstrument $ Knot3 $ \f ->
+    do (Off, x) <- f Off
+       return x
+
+-- Pass 1 of the Knot3 instrument. This pass counts the number of
+-- times knot3 is used, so that an array can be allocated to store the
+-- values during the second pass.
+instance Instrument tc (CounterTC1 Int r) ()
+                    (Knot3 a r w On Off Off tc) where
+  createInstrument _ updateCtx () =
+    wrapInstrument $ Knot3 $ \f ->
+    do void $ mkMultiPass $ updateCtx incrCounterTC1
+       (Off, x) <- f Off
+       return x
+
+instance Instrument tc (CounterTC2 Int r) (Buffer r w a)
+                    (Knot3 a r w On On Off tc) where
+  createInstrument st2ToMP updateCtx (Buffer xs) =
+    wrapInstrument $ Knot3 $ \f ->
+    do counter <- mkMultiPass $ updateCtx incrCounterTC2
+       let k = counterVal2 counter
+       (On v, x) <- f Off
+       mkMultiPass $ st2ToMP $ writeST2Array xs k v
+       return x
+
+instance Instrument tc (CounterTC2 Int r) (Buffer r w a)
+                    (Knot3 a r w On On On tc) where
+  createInstrument st2ToMP updateCtx (Buffer xs) =
+    wrapInstrument $ Knot3 $ \f ->
+    do counter <- mkMultiPass $ updateCtx incrCounterTC2
+       let k = counterVal2 counter
+       v <- mkMultiPass $ st2ToMP $ readST2Array xs k
+       (_,x) <- f (On v)
+       return x
+
+-- This instrument never needs to back-track.
+instance BackTrack r w tc (Buffer r w a)
+
+instance NextGlobalContext r w (CounterTC1 Int r)
+                           () (Buffer r w a) where
+  nextGlobalContext _ _ counter () =
+    let n = counterVal1 counter in
+    do xs <- newST2Array_ (0, n-1)
+       return (Buffer xs)
+
+instance NextGlobalContext r w tc (Buffer r w a)
+                           (Buffer r w a) where
+  nextGlobalContext _ _ _ (Buffer xs) = return (Buffer xs)
diff --git a/src/Control/Monad/MultiPass/Instrument/Monoid2.hs b/src/Control/Monad/MultiPass/Instrument/Monoid2.hs
new file mode 100644
--- /dev/null
+++ b/src/Control/Monad/MultiPass/Instrument/Monoid2.hs
@@ -0,0 +1,118 @@
+-- Copyright 2013 Kevin Backhouse.
+
+{-|
+The 'Monoid2' instrument is used to accumulate a global value during
+the first pass. During the second pass, the global value can be read
+but not written. The value must be an instance of the
+'Data.Monoid.Monoid' class. The names of the methods, 'tell' and
+'listen', are taken from the 'Control.Monad.Writer.MonadWriter'
+class. If this causes a naming conflict, then this module should be
+imported qualified. For example:
+
+> import qualified Control.Monad.MultiPass.Instrument.Monoid2 as M
+-}
+
+module Control.Monad.MultiPass.Instrument.Monoid2
+  ( Monoid2
+  , tell, listen
+  , tellPrologue, listenEpilogue
+  )
+where
+
+import Control.Monad ( void )
+import Control.Monad.MultiPass
+import Control.Monad.MultiPass.ThreadContext.MonoidTC
+import Data.Monoid
+
+-- | Abstract datatype for the instrument.
+data Monoid2 a r w p1 p2 tc
+  = Monoid2
+      { tellInternal :: !(p1 a -> MultiPassBase r w tc ())
+      , listenInternal :: !(MultiPass r w tc (p2 a))
+      , listenInternalEpilogue :: !(MultiPassEpilogue r w tc (p1 a))
+      }
+
+-- | Add a value to the global value, during the first pass.
+tell
+  :: (Monoid a, Monad p1, Monad p2)
+  => Monoid2 a r w p1 p2 tc   -- ^ Instrument
+  -> p1 a                     -- ^ Value to add
+  -> MultiPass r w tc ()
+tell m v =
+  mkMultiPass $ tellInternal m v
+
+-- | Add a value to the global value, during the prologue of the first
+-- pass.
+tellPrologue
+  :: (Monoid a, Monad p1, Monad p2)
+  => Monoid2 a r w p1 p2 tc   -- ^ Instrument
+  -> p1 a                     -- ^ Value to add
+  -> MultiPassPrologue r w tc ()
+tellPrologue m v =
+  mkMultiPassPrologue $ tellInternal m v
+
+-- | Read the global value, during the second pass.
+listen
+  :: (Monoid a, Monad p1, Monad p2)
+  => Monoid2 a r w p1 p2 tc   -- ^ Instrument
+  -> MultiPass r w tc (p2 a)  -- ^ Global value
+listen =
+  listenInternal
+
+-- | Read the global value, during the epilogue of the first pass.
+listenEpilogue
+  :: (Monoid a, Monad p1, Monad p2)
+  => Monoid2 a r w p1 p2 tc   -- ^ Instrument
+  -> MultiPassEpilogue r w tc (p1 a)  -- ^ Global value
+listenEpilogue =
+  listenInternalEpilogue
+
+-- Global context, used during the second phase.
+newtype GC a
+  = GC a
+
+instance Instrument tc () () (Monoid2 a r w Off Off tc) where
+  createInstrument _ _ () =
+    wrapInstrument $
+    Monoid2
+      { tellInternal = \Off -> return ()
+      , listenInternal = return Off
+      , listenInternalEpilogue = return Off
+      }
+
+instance Monoid a =>
+         Instrument tc (MonoidTC a) ()
+                    (Monoid2 a r w On Off tc) where
+  createInstrument _ updateCtx () =
+    wrapInstrument $
+    Monoid2
+      { tellInternal = \(On x) ->
+          void $ updateCtx (MonoidTC . mappend x . unwrapMonoidTC)
+
+      , listenInternal =
+          return Off
+
+      , listenInternalEpilogue =
+          mkMultiPassEpilogue $
+          do MonoidTC x <- updateCtx id
+             return (On x)
+      }
+
+instance Instrument tc () (GC a) (Monoid2 a r w On On tc) where
+  createInstrument _ _ (GC x) =
+    wrapInstrument $ Monoid2
+      { tellInternal = \(On _) -> return ()
+      , listenInternal = return $ On $ x
+      , listenInternalEpilogue = return $ On $ x
+      }
+
+-- This instrument never needs to back-track.
+instance BackTrack r w () (GC a)
+
+instance NextGlobalContext r w (MonoidTC a) () (GC a) where
+  nextGlobalContext _ _ (MonoidTC x) () =
+    return (GC x)
+
+instance NextGlobalContext r w () (GC a) (GC a) where
+  nextGlobalContext _ _ () gc =
+    return gc
diff --git a/src/Control/Monad/MultiPass/Instrument/OrdCons.hs b/src/Control/Monad/MultiPass/Instrument/OrdCons.hs
new file mode 100644
--- /dev/null
+++ b/src/Control/Monad/MultiPass/Instrument/OrdCons.hs
@@ -0,0 +1,211 @@
+-- Copyright 2013 Kevin Backhouse.
+
+{-|
+The 'OrdCons' instrument uses two passes to implement hash-consing.
+The values are added to the table during the first pass and a unique
+index for each value is returned during the second pass.
+
+'OrdCons' is implemented using 'Data.Map', so it can be used on any
+datatype which is an instance of 'Ord'.
+-}
+
+module Control.Monad.MultiPass.Instrument.OrdCons
+  ( OrdCons
+  , initOrdCons, ordCons, getOrdConsTable
+  , OrdConsTable
+  , lookupOrdConsTable, insertOrdConsTable, growOrdConsTable
+  )
+where
+
+import Control.Exception ( assert )
+import Control.Monad.ST2
+import Control.Monad.Writer.Strict
+import Control.Monad.MultiPass
+import Control.Monad.MultiPass.ThreadContext.MonoidTC
+import qualified Data.Map as FM
+import Data.Maybe ( isJust, fromJust )
+
+-- | Abstract datatype for the instrument.
+data OrdCons a r w p1 p2 tc
+  = OrdCons
+      { initInternal
+          :: !(p1 (OrdConsTable a) -> MultiPassPrologue r w tc ())
+
+      , ordConsInternal
+          :: !(p1 a -> MultiPass r w tc (p2 Int))
+
+      , getOrdConsTableInternal
+          :: !(MultiPassEpilogue r w tc (p2 (OrdConsTable a)))
+      }
+
+-- | Initialise the 'OrdCons' instrument with an 'OrdConsTable'.  This
+-- method is optional. Ff this method is not used then the instrument
+-- will be initialised with an empty 'OrdConsTable'.
+initOrdCons
+  :: (Ord a, Monad p1, Monad p2)
+  => OrdCons a r w p1 p2 tc       -- ^ Instrument
+  -> p1 (OrdConsTable a)          -- ^ Initial table
+  -> MultiPassPrologue r w tc ()
+initOrdCons =
+  initInternal
+
+-- | Get a unique index for the value.
+ordCons
+  :: (Ord a, Monad p1, Monad p2)
+  => OrdCons a r w p1 p2 tc       -- ^ Instrument
+  -> p1 a                         -- ^ Value
+  -> MultiPass r w tc (p2 Int)    -- ^ Unique index
+ordCons =
+  ordConsInternal
+
+-- | Get the final 'OrdConsTable'.
+getOrdConsTable
+  :: OrdCons a r w p1 p2 tc
+  -> MultiPassEpilogue r w tc (p2 (OrdConsTable a))
+getOrdConsTable =
+  getOrdConsTableInternal
+
+-- | This datatype is a newtype around @'FM.Map' a 'Int'@. It maps its
+-- keys (of type @a@) to a permutation of the integers @0..n-1@, where
+-- @n@ is the number of keys.
+newtype OrdConsTable a
+  = OrdConsTable (FM.Map a Int)
+
+-- | Empty 'OrdConsTable'.
+emptyOrdConsTable :: OrdConsTable a
+emptyOrdConsTable =
+  OrdConsTable FM.empty
+
+-- | Lookup an element.
+lookupOrdConsTable :: Ord a => OrdConsTable a -> a -> Maybe Int
+lookupOrdConsTable (OrdConsTable table) x =
+  FM.lookup x table
+
+-- | Insert an element. If the element is not in the map yet, then it
+-- is assigned index @n@, where @n@ is the original size of the table.
+insertOrdConsTable :: Ord a => OrdConsTable a -> a -> OrdConsTable a
+insertOrdConsTable (OrdConsTable table) x =
+  if FM.member x table
+     then OrdConsTable table
+     else OrdConsTable $ FM.insert x (FM.size table) table
+
+-- | Add multiple elements. The new elements are assigned indices
+-- @n..n+k-1@, where @n@ is the original size of the table and @k@ is
+-- the number of new elements to be added. This function will assert
+-- if any of the new elements are already in the table.
+growOrdConsTable
+  :: Ord a => OrdConsTable a -> FM.Map a () -> OrdConsTable a
+growOrdConsTable (OrdConsTable table) xs =
+  assert (FM.null (FM.intersection table xs)) $
+  let n = FM.size table in
+  let xs' = snd $ FM.mapAccum (\i () -> (i+1, i)) n xs in
+  OrdConsTable $ FM.union table xs'
+
+newtype GC1 r w a
+  = GC1 (ST2Ref r w (OrdConsTable a))
+
+newtype OrdConsTC a
+  = OrdConsTC (FM.Map a ())
+
+instance Ord a => Monoid (OrdConsTC a) where
+  mempty =
+    OrdConsTC FM.empty
+
+  mappend (OrdConsTC xs) (OrdConsTC ys) =
+    OrdConsTC (FM.union xs ys)
+
+instance Instrument tc () ()
+                    (OrdCons a r w Off Off tc) where
+  createInstrument _ _ () =
+    wrapInstrument $ OrdCons
+      { initInternal = \Off -> return ()
+      , ordConsInternal = \Off -> return Off
+      , getOrdConsTableInternal = return Off
+      }
+
+instance Ord a =>
+         Instrument tc (MonoidTC (OrdConsTC a)) (GC1 r w a)
+                    (OrdCons a r w On Off tc) where
+  createInstrument st2ToMP updateCtx (GC1 initTableRef) =
+    wrapInstrument $ OrdCons
+      { initInternal = \(On initTable) ->
+          mkMultiPassPrologue $
+          do -- Check that the initTableRef has not been initialised
+             -- already.
+             OrdConsTable xs <- st2ToMP $ readST2Ref initTableRef
+             assert (FM.null xs) $ return ()
+             st2ToMP $ writeST2Ref initTableRef initTable
+
+      , ordConsInternal = \(On x) ->
+          let updateTable initTable (MonoidTC (OrdConsTC table)) =
+                MonoidTC $ OrdConsTC $
+                if isJust (lookupOrdConsTable initTable x)
+                   then table
+                   else FM.insert x () table
+          in
+          mkMultiPass $
+          do initTable <- st2ToMP $ readST2Ref initTableRef
+             _ <- updateCtx (updateTable initTable)
+             return Off
+
+      , getOrdConsTableInternal =
+          return Off
+      }
+
+-- The gc2_newTable field is a superset of gc2_initTable. (The
+-- initTable is only used if back-tracking occurs.)
+data GC2 a
+  = GC2
+      { gc2_initTable :: !(OrdConsTable a)
+      , gc2_newTable  :: !(OrdConsTable a)
+      }
+
+instance Ord a => Instrument tc () (GC2 a)
+                             (OrdCons a r w On On tc) where
+  createInstrument _ _ gc =
+    let newTable = gc2_newTable gc in
+    wrapInstrument $ OrdCons
+      { initInternal = \(On _) -> return ()
+
+      , ordConsInternal = \(On x) ->
+          let m = lookupOrdConsTable newTable x in
+          assert (isJust m) $
+          return $ On $ fromJust m
+
+      , getOrdConsTableInternal =
+          return (On newTable)
+      }
+
+-- This instrument never needs to back-track.
+instance BackTrack r w tc (GC1 r w a)
+instance BackTrack r w () (GC2 a)
+
+instance NextGlobalContext r w () () (GC1 r w a) where
+  nextGlobalContext _ _ () () =
+    do initTableRef <- newST2Ref emptyOrdConsTable
+       return (GC1 initTableRef)
+
+instance NextGlobalContext r w tc (GC1 r w a) (GC1 r w a) where
+  nextGlobalContext _ _ _ gc =
+    return gc
+
+instance Ord a =>
+         NextGlobalContext r w (MonoidTC (OrdConsTC a))
+                           (GC1 r w a) (GC2 a) where
+  nextGlobalContext _ _ tc gc =
+    let GC1 initTableRef = gc in
+    let MonoidTC (OrdConsTC table) = tc in
+    do initTable <- readST2Ref initTableRef
+       return $ GC2
+         { gc2_initTable = initTable
+         , gc2_newTable  = growOrdConsTable initTable table
+         }
+
+instance NextGlobalContext r w tc (GC2 a) (GC2 a) where
+  nextGlobalContext _ _ _ gc =
+    return gc
+
+instance NextGlobalContext r w tc (GC2 a) (GC1 r w a) where
+  nextGlobalContext _ _ _ gc =
+    do initTableRef <- newST2Ref (gc2_initTable gc)
+       return (GC1 initTableRef)
diff --git a/src/Control/Monad/MultiPass/Instrument/TopKnot.hs b/src/Control/Monad/MultiPass/Instrument/TopKnot.hs
new file mode 100644
--- /dev/null
+++ b/src/Control/Monad/MultiPass/Instrument/TopKnot.hs
@@ -0,0 +1,99 @@
+-- Copyright 2013 Kevin Backhouse.
+
+{-|
+The 'TopKnot' instrument is used for knot tying across passes. It
+allows a value to be written during the epilogue of one pass and read
+during the prologue of a later pass.  Knot tying is a technique
+sometimes used in lazy functional programming, in which the definition
+of a variable depends on its own value. The lazy programming technique
+depends on an implicit two-pass ordering of the computation. For
+example, the classic repmin program produces a pair of outputs - a
+tree and an integer - and there is an implicit two-pass ordering where
+the integer is computed during the first pass and the tree during the
+second. The 'TopKnot' instrument allows the same technique to be
+applied, but the ordering of the passes is managed explicitly by the
+"Control.Monad.MultiPass" library, rather than implicitly by lazy
+evalution.
+-}
+
+module Control.Monad.MultiPass.Instrument.TopKnot
+  ( TopKnot
+  , load, store
+  )
+where
+
+import Control.Exception ( assert )
+import Control.Monad.ST2
+import Control.Monad.MultiPass
+import Data.Maybe ( isNothing, isJust, fromJust )
+
+-- | Abstract datatype for the instrument.
+data TopKnot a r w p1 p2 tc
+  = TopKnot
+      { loadInternal :: MultiPassPrologue r w tc (p2 a)
+      , storeInternal :: (p1 a) -> MultiPassEpilogue r w tc ()
+      }
+
+-- | Load the value that was stored during the first pass.
+load :: TopKnot a r w p1 p2 tc -> MultiPassPrologue r w tc (p2 a)
+load =
+  loadInternal
+
+-- | Store a value during the epilogue of the first pass. This
+-- function should be called exactly once.
+store :: TopKnot a r w p1 p2 tc -> p1 a -> MultiPassEpilogue r w tc ()
+store =
+  storeInternal
+
+-- Global Context.
+newtype GC r w a
+  = GC (ST2Ref r w (Maybe a))
+
+instance Instrument tc () () (TopKnot a r w Off Off tc) where
+  createInstrument _ _ () =
+    wrapInstrument $ TopKnot
+      { loadInternal = return Off
+      , storeInternal = \Off -> return ()
+      }
+
+-- First pass of the TopKnot instrument. The storeInternal method is
+-- expected to be called exactly once during this pass.
+instance Instrument tc () (GC r w a) (TopKnot a r w On Off tc) where
+  createInstrument st2ToMP _ (GC r) =
+    wrapInstrument $ TopKnot
+      { loadInternal = return Off
+
+      , storeInternal = \(On x) ->
+          mkMultiPassEpilogue $ st2ToMP $
+          do mx <- readST2Ref r
+             assert (isNothing mx) $ return ()
+             writeST2Ref r (Just x)
+      }
+
+-- Second pass of the TopKnot instrument.
+instance Instrument tc () (GC r w a) (TopKnot a r w On On tc) where
+  createInstrument st2ToMP _ (GC r) =
+    wrapInstrument $ TopKnot
+      { loadInternal =
+          mkMultiPassPrologue $ st2ToMP $
+          do mx <- readST2Ref r
+             assert (isJust mx) $ return ()
+             return $ On $ fromJust mx
+
+      , storeInternal = \(On x) ->
+          mkMultiPassEpilogue $ st2ToMP $
+          do mx <- readST2Ref r
+             assert (isNothing mx) $ return ()
+             writeST2Ref r (Just x)
+      }
+
+-- This instrument never needs to back-track.
+instance BackTrack r w tc (GC r w a)
+
+instance NextGlobalContext r w () () (GC r w a) where
+  nextGlobalContext _ _ () () =
+    do mx <- newST2Ref Nothing
+       return (GC mx)
+
+instance NextGlobalContext r w () (GC r w a) (GC r w a) where
+  nextGlobalContext _ _ () gc = return gc
diff --git a/src/Control/Monad/MultiPass/ThreadContext/CounterTC.hs b/src/Control/Monad/MultiPass/ThreadContext/CounterTC.hs
new file mode 100644
--- /dev/null
+++ b/src/Control/Monad/MultiPass/ThreadContext/CounterTC.hs
@@ -0,0 +1,179 @@
+-- Copyright 2013 Kevin Backhouse.
+
+-- | 'Control.Monad.MultiPass.ThreadContext.CounterTC' defines a
+-- thread context which is used to generate a series of unique
+-- consecutive numbers. It has two passes. The first pass,
+-- 'CounterTC1', creates a log of the number of new values that need
+-- to be generated in each thread. The second pass, 'CounterTC2', uses
+-- the log to compute the correct starting value for each thread, so
+-- that the threads appear to be incrementing a single global counter,
+-- even though they are operating concurrently.
+
+module Control.Monad.MultiPass.ThreadContext.CounterTC
+  ( -- * First Pass
+    CounterTC1
+  , counterVal1, incrCounterTC1, addkCounterTC1
+  , newCounterTC1
+
+    -- * Second Pass
+  , CounterTC2
+  , counterVal2, incrCounterTC2, addkCounterTC2
+  , newCounterTC2, resetCounterTC2
+  )
+where
+
+import Control.Monad.State.Strict
+import Control.Monad.ST2
+import Control.Monad.MultiPass
+
+data CounterLogSequential i r
+  = CounterLogSequential !i !(ST2RArray r Int (CounterLogParallel i r))
+
+newtype CounterLogParallel i r
+  = CounterLogParallel (ST2RArray r Int (CounterLogSequential i r))
+
+-- | 'CounterTC1' is used during the first pass. It builds up a log of
+-- the parallel tasks that were spawned, which is used during the
+-- second pass to generate a series of unique consecutive numbers.
+data CounterTC1 i r
+  = CounterTC1
+      { -- Counter log for the current node. (Accumulates in reverse.)
+        counterLog1 :: ![CounterLogParallel i r]
+
+        -- | Get the current value of the counter.
+      , counterVal1 :: !i
+      }
+
+instance Num i => ThreadContext r w (CounterTC1 i r) where
+  splitThreadContext _ _ _ =
+    return $ CounterTC1 [] 0
+
+  mergeThreadContext m getSubNode node =
+    do xs <- newST2Array_ (0,m-1)
+       c <- flip execStateT 0 $
+         sequence_
+           [ do subnode0 <- lift $ getSubNode i
+                c <- get
+                let subnode1 = subnode0 { counterVal1 = c }
+                put (c + counterVal1 subnode0)
+                subnode2 <- lift $ mkCounterLogSequential subnode1
+                lift $ writeST2Array xs i subnode2
+           | i <- [0 .. m-1]
+           ]
+       let xs' = CounterLogParallel (mkST2RArray xs)
+       return $ CounterTC1
+         { counterLog1 = xs' : counterLog1 node
+         , counterVal1 = c + counterVal1 node
+         }
+
+instance Num i =>
+         NextThreadContext r w () gc (CounterTC1 i r) where
+  nextThreadContext _ _ () _ =
+    return newCounterTC1
+
+instance Num i =>
+         NextThreadContext r w (CounterTC1 i r) gc (CounterTC1 i r) where
+  nextThreadContext _ _ _ _ =
+    return newCounterTC1
+
+-- | Create a new counter.
+newCounterTC1 :: Num i => CounterTC1 i r
+newCounterTC1 =
+  CounterTC1 [] 0
+
+-- | Increment the counter.
+incrCounterTC1 :: Num i => CounterTC1 i r -> CounterTC1 i r
+incrCounterTC1 = addkCounterTC1 1
+
+-- | Add @k@ to the counter.
+addkCounterTC1 :: Num i => i -> CounterTC1 i r -> CounterTC1 i r
+addkCounterTC1 k (CounterTC1 h c) =
+  CounterTC1 h (c+k)
+
+-- The log has been accumulated as a list in reverse order. This
+-- function reverses the list and converts it to a read-only array.
+mkCounterLogSequential
+  :: CounterTC1 i r
+  -> ST2 r w (CounterLogSequential i r)
+mkCounterLogSequential (CounterTC1 xs c) =
+  let n = length xs in
+  do xs' <- newST2Array_ (0,n-1)
+     sequence_
+       [ writeST2Array xs' (n-i) x
+       | (x,i) <- zip xs [1 .. n]
+       ]
+     return (CounterLogSequential c (mkST2RArray xs'))
+
+-- | 'CounterTC2' is used during the second pass. It uses the log
+-- which was computed by 'CounterTC1' to generate a series of unique
+-- consecutive numbers.
+data CounterTC2 i r
+  = CounterTC2
+      { counterLog2 :: !(ST2RArray r Int (CounterLogParallel i r))
+
+        -- Current index in the counter log.
+      , counterIdx2 :: !Int
+
+        -- | Get the current value of the counter.
+      , counterVal2 :: !i
+      }
+
+-- | Increment the counter.
+incrCounterTC2 :: Num i => CounterTC2 i r -> CounterTC2 i r
+incrCounterTC2 = addkCounterTC2 1
+
+-- | Add @k@ to the counter.
+addkCounterTC2 :: Num i => i -> CounterTC2 i r -> CounterTC2 i r
+addkCounterTC2 k node =
+  node { counterVal2 = k + counterVal2 node }
+
+instance Num i => ThreadContext r w (CounterTC2 i r) where
+  splitThreadContext _ i node =
+    do -- Read the current index of the log.
+       CounterLogParallel ps <-
+         readST2RArray (counterLog2 node) (counterIdx2 node)
+       -- Get the log for thread i.
+       CounterLogSequential k pss <- readST2RArray ps i
+       return $ CounterTC2
+         { counterLog2 = pss
+         , counterIdx2 = 0
+         , counterVal2 = k + counterVal2 node
+         }
+
+  mergeThreadContext m getSubNode node =
+    do -- Get the new counter value from the last sub-node.
+       lastSubNode <- getSubNode (m-1)
+       return $ node
+         { counterIdx2 = 1 + counterIdx2 node
+         , counterVal2 = counterVal2 lastSubNode
+         }
+
+instance Num i =>
+         NextThreadContext r w (CounterTC1 i r) gc (CounterTC2 i r) where
+  nextThreadContext _ _ node _ =
+    newCounterTC2 node
+
+instance Num i =>
+         NextThreadContext r w (CounterTC2 i r) gc (CounterTC1 i r) where
+  nextThreadContext _ _ _ _ =
+    return newCounterTC1
+
+instance Num i =>
+         NextThreadContext r w (CounterTC2 i r) gc (CounterTC2 i r) where
+  nextThreadContext _ _ node _ =
+    return (resetCounterTC2 node)
+
+-- | Convert a 'CounterTC1' to a 'CounterTC2'.
+newCounterTC2 :: Num i => CounterTC1 i r -> ST2 r w (CounterTC2 i r)
+newCounterTC2 node =
+  do CounterLogSequential _ pss <- mkCounterLogSequential node
+     return $ CounterTC2
+       { counterLog2 = pss
+       , counterIdx2 = 0
+       , counterVal2 = 0
+       }
+
+-- | Reset the counter to zero and rewind to the beginning of the log.
+resetCounterTC2 :: Num i => CounterTC2 i r -> CounterTC2 i r
+resetCounterTC2 node =
+  node { counterIdx2 = 0, counterVal2 = 0 }
diff --git a/src/Control/Monad/MultiPass/ThreadContext/MonoidTC.hs b/src/Control/Monad/MultiPass/ThreadContext/MonoidTC.hs
new file mode 100644
--- /dev/null
+++ b/src/Control/Monad/MultiPass/ThreadContext/MonoidTC.hs
@@ -0,0 +1,42 @@
+-- Copyright 2013 Kevin Backhouse.
+
+-- | 'Control.Monad.MultiPass.ThreadContext.MonoidTC' defines a thread
+-- context which is used to gather values from all the threads of the
+-- program. The values to be gathered must be instances of the
+-- 'Data.Monoid' class.
+
+module Control.Monad.MultiPass.ThreadContext.MonoidTC ( MonoidTC(..) )
+where
+
+import Control.Monad.Writer.Strict
+import Control.Monad.MultiPass
+
+-- | MonoidTC is a thread context which uses the Monoid interface to
+-- combine the values from multiple threads. Instances of the Monoid
+-- class are expected to be associative, so the value computed by
+-- MonoidTC is invariant under changes to the number of threads that
+-- are spawned.
+newtype MonoidTC a = MonoidTC { unwrapMonoidTC :: a }
+
+instance Monoid a => Monoid (MonoidTC a) where
+  mempty = MonoidTC mempty
+
+  mappend (MonoidTC x) (MonoidTC y) =
+    MonoidTC (mappend x y)
+
+instance Monoid a => ThreadContext r w (MonoidTC a) where
+  splitThreadContext _ _ _ =
+    return $ mempty
+
+  mergeThreadContext n f x =
+    execWriterT $
+    do tell x
+       sequence_
+         [ do y <- lift $ f i
+              tell y
+         | i <- [0 .. n-1]
+         ]
+
+instance Monoid a => NextThreadContext r w tc gc (MonoidTC a) where
+  nextThreadContext _ _ _ _ =
+    return mempty
diff --git a/src/Control/Monad/MultiPass/Utils.hs b/src/Control/Monad/MultiPass/Utils.hs
new file mode 100644
--- /dev/null
+++ b/src/Control/Monad/MultiPass/Utils.hs
@@ -0,0 +1,69 @@
+-- Copyright 2013 Kevin Backhouse.
+
+{-|
+Utility functions for the "Control.Monad.MultiPass" library.
+-}
+
+module Control.Monad.MultiPass.Utils
+  ( mapST2ArrayMP
+  , mapST2ArrayMP_
+  , pmapM
+  )
+where
+
+import Control.Monad.ST2
+import Control.Monad.MultiPass
+import Data.Ix
+import qualified Data.Traversable as T
+
+-- | This function provides a similar interface to
+-- 'Control.Monad.mapM', but is specifically for mapping over the
+-- 'ST2Array' datatype in the 'Control.Monad.MultiPass.MultiPass'
+-- monad.
+mapST2ArrayMP
+  :: (Ix i, Num i)
+  => NumThreads                  -- ^ Number of threads to spawn
+  -> ST2Array r w i a            -- ^ Input array
+  -> (a -> MultiPass r w tc b)   -- ^ Mapping function
+  -> MultiPass r w tc (ST2Array r w i b)  -- ^ Output array
+mapST2ArrayMP nThreads xs f =
+  let f' i =
+        do x <- readOnlyST2ToMP $ readST2Array xs i
+           f x
+  in
+  do bnds <- readOnlyST2ToMP $ boundsST2Array xs
+     parallelMP nThreads bnds f'
+
+-- | This function provides a similar interface to
+-- 'Control.Monad.mapM_', but is specifically for mapping over the
+-- 'ST2Array' datatype in the 'Control.Monad.MultiPass.MultiPass'
+-- monad.
+mapST2ArrayMP_
+  :: (Ix i, Num i)
+  => NumThreads                  -- ^ Number of threads to spawn
+  -> ST2Array r w i a            -- ^ Input array
+  -> (a -> MultiPass r w tc b)   -- ^ Mapping function
+  -> MultiPass r w tc ()
+mapST2ArrayMP_ nThreads xs f =
+  let f' i =
+        do x <- readOnlyST2ToMP $ readST2Array xs i
+           f x
+  in
+  do bnds <- readOnlyST2ToMP $ boundsST2Array xs
+     parallelMP_ nThreads bnds f'
+
+-- | This function provides a similar interface to
+-- 'T.Traversable.mapM', but is useful for mapping over a datatype in
+-- a specific pass of the 'Control.Monad.MultiPass.MultiPass' monad.
+-- Note: the @m@ type is usually the
+-- 'Control.Monad.MultiPass.MultiPass' monad, but the implementation
+-- does not specifically depend on anything from the
+-- "Control.Monad.MultiPass" library, so its type is more general.
+pmapM
+  :: (T.Traversable t, Monad m, Monad p)
+  => t a
+  -> (a -> m (p b))
+  -> m (p (t b))
+pmapM xs f =
+  do xs' <- T.mapM f xs
+     return (T.mapM id xs')
diff --git a/src/Control/Monad/MultiPass/Utils/InstanceTest.hs b/src/Control/Monad/MultiPass/Utils/InstanceTest.hs
new file mode 100644
--- /dev/null
+++ b/src/Control/Monad/MultiPass/Utils/InstanceTest.hs
@@ -0,0 +1,198 @@
+-- Copyright 2013 Kevin Backhouse.
+
+{-|
+For every new instrument, a number of class instances need to be
+defined, such as 'NextGlobalContext' and 'NextThreadContext'. The
+tests in this module are used to check that all the necessary
+instances have been defined. Each test defines a trivial algorithm,
+parameterised by an instrument of a specific arity. For example,
+'testInstrument3' is parameterised by a three-pass instrument. The
+test is used as follows:
+
+> instanceTest :: ST2 r w ()
+> instanceTest = run instanceTestBody
+>
+> instanceTestBody :: TestInstrument3 (MyInstrument r w) r w
+> instanceTestBody = testInstrument3
+
+If this code does not cause any compiler errors, then all the
+necessary instances have been defined for @MyInstrument@.
+-}
+
+module Control.Monad.MultiPass.Utils.InstanceTest
+         ( -- * Test for One-Pass Instruments
+           testInstrument1, TestInstrument1
+
+           -- * Test for Two-Pass Instruments
+         , testInstrument2, TestInstrument2
+
+           -- * Test for Three-Pass Instruments
+         , testInstrument3, TestInstrument3
+
+           -- * Test for Four-Pass Instruments
+         , testInstrument4, TestInstrument4
+         )
+where
+
+import Control.Monad.MultiPass
+
+
+----------------------------------------------------------------------
+------------------- Test for One-Pass Instruments --------------------
+----------------------------------------------------------------------
+
+-- | Test type for a one-pass instrument.
+type TestInstrument1 f r w
+  = PassS (PassS (PassS PassZ)) (WrappedType1 f r w)
+
+-- | Test function for a one-pass instrument.
+testInstrument1 :: TestInstrument1 f r w
+testInstrument1 =
+  PassS $ PassS $ PassS $
+  PassZ $ WrappedType1 $ testBody1
+
+type UnwrappedType1 f r w p1 p2 p3 tc
+  =  f p1 tc
+  -> f p2 tc
+  -> f p3 tc
+  -> MultiPassMain r w tc (p3 ())
+
+newtype WrappedType1 f r w p1 p2 p3 tc =
+  WrappedType1 (UnwrappedType1 f r w p1 p2 p3 tc)
+
+instance MultiPassAlgorithm
+           (WrappedType1 f r w p1 p2 p3 tc)
+           (UnwrappedType1 f r w p1 p2 p3 tc)
+           where
+  unwrapMultiPassAlgorithm (WrappedType1 f) = f
+
+testBody1
+  :: Monad p3
+  => UnwrappedType1 f r w p1 p2 p3 tc
+testBody1 _ _ _ =
+  mkMultiPassMain
+    (return ())
+    (\() -> return ())
+    (\() -> return (return ()))
+
+
+----------------------------------------------------------------------
+------------------- Test for Two-Pass Instruments --------------------
+----------------------------------------------------------------------
+
+-- | Test type for a two-pass instrument.
+type TestInstrument2 f r w
+  = PassS (PassS (PassS (PassS PassZ))) (WrappedType2 f r w)
+
+-- | Test function for a two-pass instrument.
+testInstrument2 :: TestInstrument2 f r w
+testInstrument2 =
+  PassS $ PassS $ PassS $ PassS $
+  PassZ $ WrappedType2 $ testBody2
+
+type UnwrappedType2 f r w p1 p2 p3 p4 tc
+  =  f p1 p2 tc
+  -> f p3 p4 tc
+  -> f p1 p3 tc
+  -> f p2 p4 tc
+  -> MultiPassMain r w tc (p4 ())
+
+newtype WrappedType2 f r w p1 p2 p3 p4 tc =
+  WrappedType2 (UnwrappedType2 f r w p1 p2 p3 p4 tc)
+
+instance MultiPassAlgorithm
+           (WrappedType2 f r w p1 p2 p3 p4 tc)
+           (UnwrappedType2 f r w p1 p2 p3 p4 tc)
+           where
+  unwrapMultiPassAlgorithm (WrappedType2 f) = f
+
+testBody2
+  :: Monad p4
+  => UnwrappedType2 f r w p1 p2 p3 p4 tc
+testBody2 _ _ _ _ =
+  mkMultiPassMain
+    (return ())
+    (\() -> return ())
+    (\() -> return (return ()))
+
+
+----------------------------------------------------------------------
+------------------ Test for Three-Pass Instruments -------------------
+----------------------------------------------------------------------
+
+-- | Test type for a three-pass instrument.
+type TestInstrument3 f r w
+  = PassS (PassS (PassS (PassS (PassS (PassS PassZ)))))
+          (WrappedType3 f r w)
+
+-- | Test function for a three-pass instrument.
+testInstrument3 :: TestInstrument3 f r w
+testInstrument3 =
+  PassS $ PassS $ PassS $ PassS $ PassS $ PassS $
+  PassZ $ WrappedType3 $ testBody3
+
+type UnwrappedType3 f r w p1 p2 p3 p4 p5 p6 tc
+  =  f p1 p2 p3 tc
+  -> f p4 p5 p6 tc
+  -> f p1 p3 p4 tc
+  -> f p2 p4 p6 tc
+  -> MultiPassMain r w tc (p6 ())
+
+newtype WrappedType3 f r w p1 p2 p3 p4 p5 p6 tc =
+  WrappedType3 (UnwrappedType3 f r w p1 p2 p3 p4 p5 p6 tc)
+
+instance MultiPassAlgorithm
+           (WrappedType3 f r w p1 p2 p3 p4 p5 p6 tc)
+           (UnwrappedType3 f r w p1 p2 p3 p4 p5 p6 tc)
+           where
+  unwrapMultiPassAlgorithm (WrappedType3 f) = f
+
+testBody3
+  :: Monad p6
+  => UnwrappedType3 f r w p1 p2 p3 p4 p5 p6 tc
+testBody3 _ _ _ _ =
+  mkMultiPassMain
+    (return ())
+    (\() -> return ())
+    (\() -> return (return ()))
+
+
+----------------------------------------------------------------------
+------------------- Test for Four-Pass Instruments -------------------
+----------------------------------------------------------------------
+
+-- | Test type for a four-pass instrument.
+type TestInstrument4 f r w
+  = PassS (PassS (PassS (PassS (PassS (PassS (PassS (PassS PassZ)))))))
+          (WrappedType4 f r w)
+
+-- | Test function for a four-pass instrument.
+testInstrument4 :: TestInstrument4 f r w
+testInstrument4 =
+  PassS $ PassS $ PassS $ PassS $ PassS $ PassS $ PassS $ PassS $
+  PassZ $ WrappedType4 $ testBody4
+
+type UnwrappedType4 f r w p1 p2 p3 p4 p5 p6 p7 p8 tc
+  =  f p1 p2 p3 p4 tc
+  -> f p5 p6 p7 p8 tc
+  -> f p1 p3 p5 p7 tc
+  -> f p2 p4 p6 p8 tc
+  -> MultiPassMain r w tc (p8 ())
+
+newtype WrappedType4 f r w p1 p2 p3 p4 p5 p6 p7 p8 tc =
+  WrappedType4 (UnwrappedType4 f r w p1 p2 p3 p4 p5 p6 p7 p8 tc)
+
+instance MultiPassAlgorithm
+           (WrappedType4 f r w p1 p2 p3 p4 p5 p6 p7 p8 tc)
+           (UnwrappedType4 f r w p1 p2 p3 p4 p5 p6 p7 p8 tc)
+           where
+  unwrapMultiPassAlgorithm (WrappedType4 f) = f
+
+testBody4
+  :: Monad p8
+  => UnwrappedType4 f r w p1 p2 p3 p4 p5 p6 p7 p8 tc
+testBody4 _ _ _ _ =
+  mkMultiPassMain
+    (return ())
+    (\() -> return ())
+    (\() -> return (return ()))
diff --git a/src/Control/Monad/MultiPass/Utils/UpdateCtx.hs b/src/Control/Monad/MultiPass/Utils/UpdateCtx.hs
new file mode 100644
--- /dev/null
+++ b/src/Control/Monad/MultiPass/Utils/UpdateCtx.hs
@@ -0,0 +1,67 @@
+-- Copyright 2013 Kevin Backhouse.
+
+{-|
+Utility functions for working with the 'UpdateThreadContext'
+argument of 'createInstrument'. This module is only relevant for
+Instrument authoring.
+-}
+
+module Control.Monad.MultiPass.Utils.UpdateCtx
+  ( updateCtxFst, updateCtxSnd
+  , updateCtxLeft, updateCtxRight
+  )
+where
+
+import Control.Exception ( assert )
+import Control.Monad.MultiPass
+
+-- | If the thread context is a pair then 'updateCtxFst' creates a new
+-- 'UpdateThreadContext' function which can be used to update the
+-- first element of the pair.
+updateCtxFst
+  :: UpdateThreadContext rootTC (x,y)
+  -> UpdateThreadContext rootTC x
+updateCtxFst updateCtx f =
+  do (x,_) <- updateCtx (cross f id)
+     return x
+
+-- | If the thread context is a pair then 'updateCtxSnd' creates a new
+-- 'UpdateThreadContext' function which can be used to update the
+-- second element of the pair.
+updateCtxSnd
+  :: UpdateThreadContext rootTC (x,y)
+  -> UpdateThreadContext rootTC y
+updateCtxSnd updateCtx f =
+  do (_,y) <- updateCtx (cross id f)
+     return y
+
+cross :: (a -> a') -> (b -> b') -> (a,b) -> (a',b')
+cross f g (x,y) = (f x, g y)
+
+-- | If the thread context is an Either of two thread contexts then
+-- 'updateCtxLeft' creates a new 'UpdateThreadContext' function which
+-- can be used to update the 'Left' element. This function will assert
+-- if the thread context is a 'Right' element.
+updateCtxLeft
+  :: UpdateThreadContext rootTC (Either x y)
+  -> UpdateThreadContext rootTC x
+updateCtxLeft updateCtx f =
+  let g (Left x) = Left (f x)
+      g (Right _) = assert False $ error "updateCtxLeft"
+  in
+  do Left x <- updateCtx g
+     return x
+
+-- | If the thread context is an Either of two thread contexts then
+-- 'updateCtxRight' creates a new 'UpdateThreadContext' function which
+-- can be used to update the 'Right' element. This function will assert
+-- if the thread context is a 'Left' element.
+updateCtxRight
+  :: UpdateThreadContext rootTC (Either x y)
+  -> UpdateThreadContext rootTC y
+updateCtxRight updateCtx f =
+  let g (Left _) = assert False $ error "updateCtxRight"
+      g (Right x) = Right (f x)
+  in
+  do Right x <- updateCtx g
+     return x
diff --git a/tests/Main.hs b/tests/Main.hs
new file mode 100644
--- /dev/null
+++ b/tests/Main.hs
@@ -0,0 +1,38 @@
+-- Copyright 2013 Kevin Backhouse.
+
+module Main where
+
+import Test.Framework as TF ( defaultMain, testGroup, Test )
+import qualified TestAssembler
+import qualified TestCFG
+import qualified TestCFG2
+import qualified TestCounter
+import qualified TestLocalmin
+import qualified TestOrdCons
+import qualified TestRepmin
+import qualified TestStringInterning
+
+-- These modules currently only contain instance tests:
+import TestCreateST2Array ()
+import TestDelay ()
+import TestDelayedLift ()
+import TestEmitST2Array ()
+import TestEmitST2ArrayFxp ()
+import TestKnot3 ()
+import TestMonoid2 ()
+import TestTopKnot ()
+
+main :: IO ()
+main = defaultMain tests
+
+tests :: [TF.Test]
+tests =
+  [ testGroup "Assembler" TestAssembler.tests
+  , testGroup "CFG" TestCFG.tests
+  , testGroup "CFG2" TestCFG2.tests
+  , testGroup "Counter" TestCounter.tests
+  , testGroup "Localmin" TestLocalmin.tests
+  , testGroup "OrdCons" TestOrdCons.tests
+  , testGroup "Repmin" TestRepmin.tests
+  , testGroup "TestStringInterning" TestStringInterning.tests
+  ]