Control-Monad-MultiPass (empty) → 0.1.0.0

raw patch · 29 files changed

+4171/−0 lines, 29 filesdep +Control-Monad-ST2dep +QuickCheckdep +arraysetup-changed

Dependencies added: Control-Monad-ST2, QuickCheck, array, base, containers, mtl, test-framework, test-framework-hunit, test-framework-quickcheck2

Files

• Control-Monad-MultiPass.cabal +86/−0
• LICENSE +30/−0
• README.txt +2/−0
• Setup.hs +4/−0
• src/Control/Monad/MultiPass.hs +972/−0
• src/Control/Monad/MultiPass/Example/Assembler.hs +200/−0
• src/Control/Monad/MultiPass/Example/CFG.hs +113/−0
• src/Control/Monad/MultiPass/Example/CFG2.hs +122/−0
• src/Control/Monad/MultiPass/Example/Counter.hs +66/−0
• src/Control/Monad/MultiPass/Example/Localmin.hs +95/−0
• src/Control/Monad/MultiPass/Example/OrdCons.hs +51/−0
• src/Control/Monad/MultiPass/Example/Repmin.hs +158/−0
• src/Control/Monad/MultiPass/Example/StringInterning.hs +58/−0
• src/Control/Monad/MultiPass/Instrument/Counter.hs +114/−0
• src/Control/Monad/MultiPass/Instrument/CreateST2Array.hs +78/−0
• src/Control/Monad/MultiPass/Instrument/Delay.hs +39/−0
• src/Control/Monad/MultiPass/Instrument/DelayedLift.hs +61/−0
• src/Control/Monad/MultiPass/Instrument/EmitST2Array.hs +258/−0
• src/Control/Monad/MultiPass/Instrument/EmitST2ArrayFxp.hs +545/−0
• src/Control/Monad/MultiPass/Instrument/Knot3.hs +98/−0
• src/Control/Monad/MultiPass/Instrument/Monoid2.hs +118/−0
• src/Control/Monad/MultiPass/Instrument/OrdCons.hs +211/−0
• src/Control/Monad/MultiPass/Instrument/TopKnot.hs +99/−0
• src/Control/Monad/MultiPass/ThreadContext/CounterTC.hs +179/−0
• src/Control/Monad/MultiPass/ThreadContext/MonoidTC.hs +42/−0
• src/Control/Monad/MultiPass/Utils.hs +69/−0
• src/Control/Monad/MultiPass/Utils/InstanceTest.hs +198/−0
• src/Control/Monad/MultiPass/Utils/UpdateCtx.hs +67/−0
• tests/Main.hs +38/−0

@@ -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

@@ -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.

@@ -0,0 +1,2 @@+Control-Concurrent-MultiPass+============================

@@ -0,0 +1,4 @@+-- Copyright 2013 Kevin Backhouse.++import Distribution.Simple+main = defaultMain

@@ -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

@@ -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))

@@ -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

@@ -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

@@ -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')

@@ -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))

@@ -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

@@ -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)

@@ -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)

@@ -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+      }

@@ -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'

@@ -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

@@ -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)

@@ -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 }

@@ -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)

@@ -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)

@@ -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

@@ -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)

@@ -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

@@ -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 }

@@ -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

@@ -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')

@@ -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 ()))

@@ -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

@@ -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+  ]