ConcurrentUtils 0.4.4.0 → 0.4.5.0

raw patch · 13 files changed

+742/−984 lines, 13 filesdep +arrowsdep +hashabledep +hashtablesdep −RSAdep −binarydep −bytestringPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: arrows, hashable, hashtables, monad-loops, stm, strict, ttrie

Dependencies removed: RSA, binary, bytestring, crypto-random, cryptohash, network, process, reexport-crypto-random, securemem

API changes (from Hackage documentation)

Files

• ConcurrentUtils.cabal +9/−6
• Control/CUtils/AList.hs +7/−3
• Control/CUtils/Channel.hs +3/−78
• Control/CUtils/Conc.hs +7/−6
• Control/CUtils/DataParallel.hs +453/−281
• Control/CUtils/Deadlock.hs +156/−163
• Control/CUtils/Dyn.hs +26/−0
• Control/CUtils/FChan.hs +2/−2
• Control/CUtils/NetChan.hs +0/−358
• Control/CUtils/Processes.hs +0/−74
• Control/CUtils/StrictArrow.hs +1/−1
• Control/CUtils/ThreadPool.hs +51/−0
• Data/BellmanFord.hs +27/−12

@@ -2,20 +2,23 @@ -- documentation, see http://haskell.org/cabal/users-guide/
 
 name:                ConcurrentUtils
-version:             0.4.4.0
+version:             0.4.5.0
 synopsis:            Concurrent utilities
--- description:         
-homepage:            http://alkalisoftware.net
+description: Release notes for version 0.4.5.0:
+  .
+  * The countA operation on .DataParallel didn't fuse very well. It has been replaced by a more general countA that generates a list of indices.
+  .
+  * Removed most code for Channel library; it now passes through to Chan.
 license:             GPL-2
 license-file:        LICENSE
 author:              James Candy
-maintainer:          info@alkalisoftware.net
+maintainer:          jacinablackbox@yahoo.com
 -- copyright:           
 category:            Concurrency
 build-type:          Simple
 cabal-version:       >=1.8
 
 library
-  exposed-modules:     Control.CUtils.Processes, Control.CUtils.NetChan, Control.CUtils.FChan, Control.CUtils.Deadlock, Control.CUtils.Conc, Control.CUtils.Channel, Control.CUtils.AList, Control.CUtils.StrictArrow, Data.BellmanFord, Control.CUtils.DataParallel
+  exposed-modules:     Control.CUtils.FChan, Control.CUtils.Deadlock, Control.CUtils.Conc, Control.CUtils.ThreadPool, Control.CUtils.AList, Control.CUtils.StrictArrow, Data.BellmanFord, Control.CUtils.DataParallel, Control.CUtils.Dyn, Control.CUtils.Channel
   other-modules:       Control.CUtils.Split
-  build-depends:       base >=4.4.0.0 && <=5, process, network >=2.4, bytestring, binary, containers, array, parallel, cryptohash >=0.11.6, RSA >=2.1.0, crypto-random >=0.0.8, securemem >= 0.1.7, reexport-crypto-random, tagged >= 0.7.3, MonadRandom, monads-tf, list-extras
+  build-depends:       base >=4.4.0.0 && <=5, containers, array, parallel, tagged >= 0.7.3, MonadRandom, monads-tf, list-extras, arrows >= 0.4.4.1, strict >= 0.3.2, monad-loops >= 0.4.3, stm >= 2.4.4, hashable >= 1.2.3.3, hashtables >= 1.2.1.0, ttrie == 0.1.2

@@ -15,8 +15,10 @@ 
 instance Monad AList where
 	return x = List [x]
-	Append ls ls2 >>= f = ((ls >>= f) `par` (ls2 >>= f)) `pseq` Append (ls >>= f) (ls2 >>= f)
-	List ls >>= f = foldr mplus mzero (map f ls)
+	Append ls ls2 >>= f = (a1 `par` a2) `pseq` Append a1 a2 where
+		a1 = ls >>= f
+		a2 = ls2 >>= f
+	List ls >>= f = foldr (mplus.f) mzero ls
 
 instance MonadPlus AList where
 	mzero = List []
@@ -51,7 +53,9 @@ noNils (Append m n) = noNils m `mplus` noNils n
 noNils ls = ls
 
-assocFold0 f (Append ls ls2) = (assocFold0 f ls `par` assocFold0 f ls2) `pseq` f (assocFold0 f ls) (assocFold0 f ls2)
+assocFold0 f (Append ls ls2) = (x `par` y) `pseq` f x y where
+	x = assocFold0 f ls
+	y = assocFold0 f ls2
 assocFold0 f (List ls) = foldl1 f ls
 
 -- | Folds the AList with a function, that must be associative. This allows parallelism to be introduced.

@@ -1,83 +1,8 @@ {-# LANGUAGE FlexibleContexts #-}
 
--- | A lock-free channel (queue) data structure.
-module Control.CUtils.Channel (Channel, newChannel, writeChannel, readChannel, tryReadChannel) where
-
-import Control.Concurrent.MVar
-import Control.Monad
-import Data.IORef
-import Data.Bits
-import Data.Word
-import Data.List
-import Data.Array.MArray
-
-count pred f = fst . head . dropWhile (not . pred . snd) . zip [0..] . iterate f
-
-nBits x = count (==0) (`shiftR` 1) x
-
-data Channel a t = Channel
-	Word32
-	(a Word32 t)
-	(IORef Word32){-maybe filled-}
-	(IORef Word32){-filled-}
-	(IORef Word32){-maybe empty-}
-	(IORef Word32){-empty-}
-	(MVar ()){-full lock-}
-	(MVar ()){-empty lock-}
-
--- | Create a channel with a buffer at least as big as 'buffer'.
-newChannel :: (MArray a t IO) => Word32 -> IO (Channel a t)
-newChannel buffer = do
-	-- Adjust the buffer up to the next power of two.
-	let buffer' = shiftL 1 (nBits buffer)
-
-	-- Create array
-	a <- newArray_ (0, buffer' - 1)
-	
-	-- Create indices
-	mf <- newIORef 0
-	f <- newIORef 0
-	me <- newIORef 0
-	e <- newIORef 0
-
-	-- Create locks
-	fl <- newMVar ()
-	el <- newEmptyMVar
-
-	return (Channel buffer' a mf f me e fl el)
-
-increment ref = atomicModifyIORef ref (\x -> (x + 1, x))
-
-alg buffer off a mx x my y lx ly f = do
-	mXN <- increment mx
-	let spin = do
-		yN <- readIORef y
-		if yN + off <= mXN then do
-				mYN <- readIORef my
-				when (yN == mYN) $ takeMVar lx
-				spin
-			else do
-				val <- f a (mXN `mod` buffer)
-				increment x
-				tryPutMVar ly ()
-				return val
-	spin
+module Control.CUtils.Channel (Channel, module Control.Concurrent.Chan) where
 
--- | Write into the channel, blocking when the buffer is full.
-writeChannel (Channel buffer a mf f me e fl el) x = alg buffer buffer a mf f me e fl el (\a i -> writeArray a i x)
+import Control.Concurrent.Chan
 
--- | Read from the channel, blocking when the buffer is empty.
-readChannel (Channel buffer a mf f me e fl el) = alg buffer 0 a me e mf f el fl readArray
+type Channel = Chan
 
--- |
-tryReadChannel (Channel buffer a _ f me e fl _) = do
-	meN <- increment me
-	fN <- readIORef f
-	if fN <= meN then do
-			increment e
-			return Nothing
-		else do
-			val <- readArray a (meN `mod` buffer)
-			increment e
-			tryPutMVar fl ()
-			return (Just val)

@@ -1,12 +1,13 @@-{-# LANGUAGE Trustworthy, ScopedTypeVariables, DeriveDataTypeable, ImplicitParams #-}
+{-# LANGUAGE Trustworthy, ScopedTypeVariables, DeriveDataTypeable, ImplicitParams, FlexibleInstances, FlexibleContexts #-}
 -- | A module of concurrent higher order functions.
-module Control.CUtils.Conc (ExceptionList(..), ConcException(..), assocFold, Concurrent(..), concF_, concF, conc_, conc, concP, progressConcF, oneOfF, oneOf) where
+module Control.CUtils.Conc (module Control.CUtils.ThreadPool, ExceptionList(..), ConcException(..), assocFold, Concurrent(..), concF_, concF, conc_, conc, concP, progressConcF, oneOfF, oneOf) where
 
 import Prelude hiding (catch)
 import Control.Exception
 import Data.Typeable
 import Control.Concurrent.QSemN
 import Control.Concurrent.Chan
+import Control.CUtils.ThreadPool
 import GHC.Conc
 import Data.Array.IO (newArray_, readArray, writeArray, getElems, IOArray)
 import Data.Array
@@ -29,7 +30,7 @@ 
 simpleConc_ mnds = do
 	sem <- newQSemN 0
-	mapM_ (\m -> forkIO (do
+	mapM_ (\m -> addToPool ?pool (do
 			m
 			signalQSemN sem 1))
 		mnds
@@ -59,10 +60,10 @@ 	--   Note: this function only spawns enough threads to make effective use of the /capabilities/.
 	--   Any two list elements may be processed sequentially or concurrently. To get parallelism,
 	--   you have to set the numCapabilities value, e.g. using GHC's +RTS -N flag.
-	arr_assocFold :: a (b, b) b -> (c -> b) -> a (b, Array Int c) b
+	arr_assocFold :: (?pool :: BoxedThreadPool) => a (b, b) b -> (c -> b) -> a (b, Array Int c) b
 	-- | The first parameter is the number of computations which are indexed from 0 to n - 1.
-	arr_concF_ :: (?seq :: Bool) => a (t, Int) () -> a (t, Int) ()
-	arr_concF :: (?seq :: Bool) => a (u, Int) t -> a (u, Int) (Array Int t)
+	arr_concF_ :: (?seq :: Bool, ?pool :: BoxedThreadPool) => a (t, Int) () -> a (t, Int) ()
+	arr_concF :: (?seq :: Bool, ?pool :: BoxedThreadPool) => a (u, Int) t -> a (u, Int) (Array Int t)
 	arr_oneOfF :: a (u, Int) b -> a (u, Int) b
 
 instance Concurrent (Kleisli IO) where

@@ -1,281 +1,453 @@-{-# LANGUAGE Safe, GADTs, Rank2Types, ImplicitParams, Arrows #-}--- | An implementation of nested data parallelism (due to Simon Peyton Jones et al)-module Control.CUtils.DataParallel (--- * Flattenable arrays-ArrC, newArray, inject, project,--- * The arrows and associated operations-Structural, A, unA, mapA', liftA, countA, indexA, zipA, unzipA, concatA, eval,--- * Examples-nQueens, sorting, permute) where--import Data.Array-import Data.List-import Data.Monoid (Any(Any))-import Control.Category-import Control.Arrow-import Control.Monad.Writer (Writer, tell, runWriter)-import Control.Monad.Identity-import Control.Monad-import Control.CUtils.Conc-import Control.CUtils.StrictArrow-import Prelude hiding (id, (.))--data Tree t = Node !t !(Array Int (Tree t))--data ArrC t = ArrC !(Array Int t) !(Array Int (Tree Int))--newArray ls = listArray (0, length ls - 1) ls--inject ar = ArrC (ixmap (0, uncurry subtract (bounds ar)) (subtract (fst (bounds ar))) ar) (newArray [Node 0 (newArray []), Node (uncurry subtract (bounds ar) + 1) (newArray [])])--project (ArrC ar _) = ar--instance Functor ArrC where-	fmap f (ArrC ar fr) = ArrC (fmap f ar) fr--instance Show (t -> u) where-	showsPrec _ _ = ("<FUNCTION>"++)--data Structural a t u where-	Map :: Structural a t u -> Structural a (ArrC t) (ArrC u)-	Comp :: Structural a u v -> Structural a t u -> Structural a t v-	Id :: Structural a t t-	Product :: Structural a t u -> Structural a v w -> Structural a (t, v) (u, w)-	Lift :: a t u -> Structural a t u-	Count :: Structural a (t, Int) (ArrC (t, Int))-	Index :: Structural a (ArrC t, Int) t-	Zip :: Structural a (ArrC t, ArrC u) (ArrC (t, u))-	Unzip :: Structural a (ArrC (t, u)) (ArrC t, ArrC u)-	ClearMarks :: Structural a (ArrC t) (ArrC t)-	Separate :: Structural a (Either t u) (ArrC t, ArrC u)-	Combine :: Structural a (ArrC t, ArrC u) (Either t u)-	Pack :: Structural a (ArrC (ArrC t)) (ArrC t)-	Unpack :: Structural a (ArrC t) (ArrC (ArrC t))---- | The 'A' arrow includes a set of primitives that may be executed concurrently.---   Programs are incrementally optimized as they are put together. A program may be---   optimized once, and the result saved for repeated use.------ Notes:------   * The exact output of the optimizer is subject to change.------   * The program must be a finite data structure, or optimization will diverge.-data A a t u = A (forall v. Structural a v t -> Structural a v u)--data Equal t u = (t ~ u) => Equal--reassociate :: (Category a) => Structural a u v -> Either (Equal t u) (Structural a t u) -> Structural a t v-reassociate (Comp a Id) = reassociate a-reassociate (Comp a a2) = reassociate a . Right . reassociate a2-reassociate a = either (\Equal -> a) (a.)---- | Obtain a 'Structural' program from an 'A' program.-unA (A f) = f id---- | Obtain a 'Structural' program but postcompose with another program. -unA' :: A a u v -> Structural a t u -> Structural a t v-unA' (A f) = f--mapA' :: (ArrowChoice a) => A a t u -> A a (ArrC t) (ArrC u)-mapA' (A f) = mapA (f id)--liftA :: (Category a) => a t u -> A a t u-liftA a = A (\a2 -> case a2 of-	Comp (Lift a2) a3 -> Comp (Lift (a . a2)) a3-	_ -> Lift a . a2)--pack :: (Category a) => A a (ArrC (ArrC t)) (ArrC t)-pack = A (\a -> case a of-	Comp (Map (Comp (Map a) a2)) a3 -> Map a . unA' pack (Map a2 . a3)-	Comp (Map (Map a)) a2 -> Map a . unA' pack a2-	Comp (Map (Comp Pack a)) a2 -> unA' pack (unA' pack (Map a . a2))-	Comp (Map Pack) a2 -> unA' pack (unA' pack a2)-	Comp Unpack a2 -> a2-	_ -> Pack . a)--flatten :: Structural a t u -> Bool-flatten (Comp a a2) = flatten a || flatten a2-flatten Id = False-flatten Unpack = False-flatten Pack = False-flatten Zip = False-flatten Unzip = False-flatten Separate = False-flatten Combine = False-flatten _ = True---- | Mapping is the primary way of constructing nested data parallel programs.---   It applies an (arrow) transformation to each element of an array---   uniformly. A form of flattening transformation is applied to nested---   maps (following the NESL paper). The flattening transformation converts---   two levels of 'Map' into one level.-mapA :: (ArrowChoice a) => Structural a t u -> A a (ArrC t) (ArrC u)-mapA (Map a) | flatten a = A (\a2 -> case a2 of-	Comp Unpack a3 -> Unpack . unA' (mapA a) a3-	_ -> Unpack . unA' (mapA a) (unA' pack a2))-mapA (Comp a a2) = mapA a . mapA a2-mapA Id = id-mapA (Product a a2) = zipA . (mapA a *** mapA a2) . unzipA-mapA Unpack = A (\a -> case a of-	Comp Unpack a -> Unpack . (Unpack . a)-	Comp (Map (Comp Pack a)) a2 -> Map a . a2-	Comp (Map Pack) a -> a-	_ -> Map Unpack . a)-mapA Count = A (Comp Unpack) . arr (\(ArrC ar fr) -> ArrC-	(newArray $ concatMap (\(x, n) -> map ((,) x) [0..n-1]) $ elems ar)-	(newArray $ zipWith Node (scanl (\n (_, m) -> n + m) 0 $ elems ar)-		(map (\(_, n) -> newArray [Node 0 (newArray []), Node n (newArray [])]) (elems ar) ++ [newArray []])))-mapA a = A (\a2 -> case a2 of-	Comp (Map a2) a3 -> Comp (Map (reassociate a (Right a2))) a3-	_ -> Comp (Map a) a2)--instance (Category a) => Category (A a) where-	id = A (\a -> a)-	A f . A g = A (f . g)--instance (ArrowChoice a) => Arrow (A a) where-	arr = liftA . arr-	A f *** A g = A (\a -> case a of-		Comp (Product a2 a3) a4 -> Product (f a2) (g a3) . a4-		_ -> Product (f id) (g id) . a)-	first a = a *** id-	second a = id *** a--instance (ArrowChoice a) => ArrowChoice (A a) where-	a +++ a2 = A (\a3 -> case a3 of-		Comp Combine a3 -> Combine . unA' (mapA (unA a) *** mapA (unA a2)) a3-		_ -> Combine . unA' (mapA (unA a) *** mapA (unA a2)) (Separate . a3))-	left a = a +++ id-	right a = id +++ a--instance Show (Structural a t u) where-	showsPrec prec (Map a) = ("Map " ++) . showParen (prec==11) (showsPrec 11 a)-	showsPrec _ (Comp a a2) = showsPrec 11 a . (" . "++) . showsPrec 11 a2-	showsPrec prec (Product a a2) = showParen (prec>=3) (showsPrec 3 a . (" *** "++) . showsPrec 3 a2)-	showsPrec _ Count = ("Count"++)-	showsPrec _ Index = ("Index"++)-	showsPrec _ Zip = ("Zip"++)-	showsPrec _ Unzip = ("Unzip"++)-	showsPrec _ ClearMarks = ("Clr"++)-	showsPrec _ Pack = ("Pk"++)-	showsPrec _ Unpack = ("Unpk"++)-	showsPrec _ Separate = ("Sep"++)-	showsPrec _ Combine = ("Comb"++)-	showsPrec _ _ = ("_"++)--instance (Category a) => Category (Structural a) where-	id = Id-	(.) = Comp--mirror ei = either Right Left ei---- | Supplies an array of a repeated value paired with the index of each element.-countA = A (Comp Count)---- | Access one index of an array.-indexA = A (Comp Index)---- | An operation analogous to 'zip'.-zipA :: (Category a) => A a (ArrC t, ArrC u) (ArrC (t, u))-zipA = A (\a -> case a of-	Comp Unzip a2 -> a2-	Comp (Product (Map a) (Map a2)) a3 -> Map (Product a a2) . unA' zipA a3-	Comp (Product (Map a) Id) a3 -> Map (Product a Id) . unA' zipA a3-	Comp (Product Id (Map a2)) a3 -> Map (Product Id a2) . unA' zipA a3-	_ -> Zip . a)---- | 'unzipA' and 'zipA' are inverses.-unzipA :: (Category a) => A a (ArrC (t, u)) (ArrC t, ArrC u)-unzipA = A (\a -> case a of-	Comp Zip a2 -> a2-	Comp (Map (Product a2 a3)) a4 -> Product (Map a2) (Map a3) . unA' unzipA a4-	_ -> Unzip . a)--concatA :: (Category a) => A a (ArrC (ArrC t)) (ArrC t)-concatA = A (Comp ClearMarks) . pack--forcePair (x, y) = x `seq` y `seq` (x, y)---- | An evaluator for 'Structural' arrows.-eval0 :: (Concurrent a, Strict a, ArrowChoice a, ?seq :: Bool) => Structural a t u -> a t u-eval0 Count = arr_concF id >>> arr inject-eval0 Index = arr (\(ArrC ar _, i) -> ar ! i)-eval0 Zip = arr (\pr@(ArrC ar _, ArrC ar2 _) -> (pr, (snd (bounds ar) `min` snd (bounds ar2)) + 1))-	>>> arr_concF (arr (\((ArrC ar _, ArrC ar2 _), i) ->-	forcePair (ar ! i, ar2 ! i)))-	>>> arr inject-eval0 Unzip = arr (\ar -> (fmap fst ar, fmap snd ar))-eval0 ClearMarks =-	arr (\(ArrC ar fr) ->-		ArrC ar (newArray [ Node (i + j) fr3 | Node i fr2 <- elems fr, Node j fr3 <- elems fr2 ]))-eval0 (Map a) = (arr (\(ArrC ar _) -> (ar, uncurry subtract (bounds ar) + 1)) >>> arr_concF (arr (uncurry (!)) >>> eval0 a)) &&& arr (\(ArrC _ fr) -> fr) >>> arr (uncurry ArrC)-eval0 Pack = arr (\(ArrC ar _) -> ArrC (newArray $ concatMap (elems . project) $ elems ar)-	(newArray $ zipWith Node (scanl (\i (ArrC ar _) -> i + rangeSize (bounds ar)) 0 $ elems ar)-		(map (\(ArrC _ fr) -> fr) (elems ar) ++ [newArray []])))-eval0 Unpack = arr (\ arc@(ArrC _ fr) -> (arc, uncurry subtract (bounds fr))) >>> arr_concF (arr (\(ArrC ar fr, index) ->-	let-		Node i fr2 = fr ! index-		Node j _ = fr ! (index + 1) in-	ArrC (ixmap (0, j-i-1) (+i) ar) fr2))-	>>> arr inject-eval0 Separate = arr (\ei -> ((,) $! either (\x -> inject $ newArray [x]) (\_ -> inject $ newArray []) ei) $! either (\_ -> inject $ newArray []) (\x -> inject $ newArray [x]) ei)-eval0 Combine = arr (\(ar, ar2) -> let-	a1 = project ar-	a2 = project ar2 in-	if uncurry subtract (bounds (project ar)) == 0 then Left $! a1 ! 0 else Right $! a2 ! 0)-eval0 (Comp a a2) = force (eval0 a) . eval0 a2-eval0 Id = id-eval0 (Lift a) = a-eval0 (Product a a2) = arr forcePair . force (second (eval0 a2)) . arr forcePair . first (eval0 a)---- | Evaluates arrows.------ Notes:------   * Effects are supported, but with much weaker semantics than the Kleisli arrows---   of the monad. In particular, the 'Map' and '***' operations are allowed to be parallelized,---   but on the other hand parallelism is not guaranteed.--eval a = let ?seq = True in eval0 a--instance (Concurrent a, Strict a, ArrowChoice a, ArrowApply a) => ArrowApply (A a) where-	app = first (arr (eval . unA)) >>> liftA app-----------------------------------checkThreats n positions = n `elem` positions -- Check if there is a piece on the row-	|| n `elem` zipWith (-) positions [1..] -- ... the diagonal-	|| n `elem` zipWith (+) positions [1..] -- ... or the other diagonal--checkThreats2 positions = or [ checkThreats n tl | n:tl <- tails positions ]--nQueensImpl :: Int -> Int -> A (->) [Int] (ArrC [Int])-nQueensImpl _ n | n <= 0 = arr (\soln -> if checkThreats2 soln then inject (newArray []) else inject (newArray [soln]))-nQueensImpl m n = arr (\partialSoln -> (partialSoln, m)) >>> countA >>>-	mapA'-		(arr (uncurry (flip (:))) >>> nQueensImpl m (pred n))-	>>> concatA--nQueens n = arr (\() -> []) >>> nQueensImpl n n-----------------------------------sorting :: (Ord t) => Int -> A (->) (ArrC t) (ArrC t)-sorting depth | depth <= 0 = arr (inject . newArray . sort . elems . project)-sorting depth = arr (\x -> if uncurry subtract (bounds (project x)) <= 0 then Left x else Right x)-	>>> id-		||| (arr (\ar -> let-			x:xs = elems (project ar)-			(bef, aft) = partition (<x) xs in-			((inject (newArray bef), inject (newArray aft)), x))-			>>> first (s *** s)-			>>> arr (\((bef, aft), x) -> inject (newArray (elems (project bef) ++ x : elems (project aft)))))-	where s = sorting (pred depth) -- Memoize the answer--- In order to make this recursive function a finite structure, there is a depth limit--- parameter, beyond which the standard 'sort' takes over.-----------------------------------permute :: A (->) (ArrC Int) (ArrC Int)-permute = arr (\ar -> (ar, uncurry subtract (bounds (project ar)) + 1)) >>> countA >>> mapA' indexA+{-# LANGUAGE Trustworthy, GADTs, Rank2Types, ImplicitParams, Arrows, DeriveFunctor #-}
+-- | An implementation of nested data parallelism (due to Simon Peyton Jones et al)
+module Control.CUtils.DataParallel (Equal(Equal),
+-- * Flattenable arrays
+ArrC, newArray, inject, project,
+-- * The arrows and associated operations
+Structural, A, unA, mapA', liftA, countA, countA', splitOff, assoc, indexA, zipA, unzipA, concatA, dupA, fstA, sndA, eval,
+-- * Examples
+nQueens, sorting, permute, dotProduct, transpose') where
+
+import qualified Data.Sequence as S
+import Data.Array
+import Data.List
+import Data.Monoid (Any(Any))
+import Data.Foldable (toList)
+import Control.Parallel
+import Control.Parallel.Strategies
+import Control.Category
+import Control.Arrow
+import Control.Monad.Writer (Writer, tell, runWriter)
+import Control.Monad.Identity
+import Control.Monad
+import Control.CUtils.Conc
+import Control.CUtils.StrictArrow
+import Prelude hiding (id, (.))
+
+data Tree t = Node !t !(S.Seq (Tree t))
+
+instance Functor Tree where
+	-- 'fmap' on trees has the recurrence:
+	-- U(n) = U(n/2) + n/c log^2(n) [based on the lemma about 'fastConcat'].
+	-- assuming unlimited capabilities.
+	-- It solves as O(n/c log^3 n).
+	fmap f (Node x sq) =
+		let sq' = fastConcat (return . fmap f) sq in
+		(toList sq' `using` parList rseq) `pseq` Node (f x) sq'
+
+data ArrC t = ArrC !(Array Int t) !(S.Seq (Tree Int)) deriving Functor
+
+newArray ls = listArray (0, length ls - 1) ls
+
+inject ar = ArrC (ixmap (0, uncurry subtract (bounds ar)) (subtract (fst (bounds ar))) ar) (S.fromList [Node 0 S.empty, Node (uncurry subtract (bounds ar) + 1) S.empty])
+
+project (ArrC ar _) = ar
+
+instance Show (t -> u) where
+	showsPrec _ _ = ("<FUNCTION>"++)
+
+data Structural a t u where
+	Map :: Structural a t u -> Structural a (ArrC t) (ArrC u)
+	Comp :: Structural a u v -> Structural a t u -> Structural a t v
+	Id :: Structural a t t
+	Product :: Structural a t u -> Structural a v w -> Structural a (t, v) (u, w)
+	Lift :: a t u -> Structural a t u
+	Count :: Structural a (t, [Int]) (ArrC (t, [Int]))
+	Index :: Structural a (ArrC t, Int) t
+	Split :: Structural a (ArrC t, Array Int Int) (ArrC t)
+	{-Zip :: Structural a (ArrC t, ArrC u) (ArrC (t, u))
+	Unzip :: Structural a (ArrC (t, u)) (ArrC t, ArrC u)-}
+	ClearMarks :: Structural a (ArrC t) (ArrC t)
+	Separate :: Structural a (Either t u) (ArrC t, ArrC u)
+	Combine :: Structural a (ArrC t, ArrC u) (Either t u)
+	Pack :: Structural a (ArrC (ArrC t)) (ArrC t)
+	Unpack :: Structural a (ArrC t) (ArrC (ArrC t))
+	Dup :: Structural a t (t, t)
+	Fst :: Structural a (t, u) t
+	Snd :: Structural a (t, u) u
+
+-- | The 'A' arrow includes a set of primitives that may be executed concurrently.
+--   Programs are incrementally optimized as they are put together. A program may be
+--   optimized once, and the result saved for repeated use.
+--
+-- Notes:
+--
+--   * The exact output of the optimizer is subject to change.
+--
+--   * The program must be a finite data structure, or optimization may diverge.
+--     Therefore recursive definitions do not work, unless something is done to
+--     limit the depth.
+data A a t u = A (forall v. Structural a v t -> Structural a v u)
+
+sHead sq = case S.viewl sq of x S.:< _ -> x
+
+sTail sq = case S.viewl sq of
+	_ S.:< xs -> xs
+	S.EmptyL -> S.empty
+
+sLast sq = case S.viewr sq of _ S.:> x -> x
+
+fromTo :: Int -> Int -> S.Seq t -> S.Seq t
+fromTo n1 n2 sq =
+	let (sq1, _) = S.splitAt n2 sq in
+		snd$S.splitAt n1 sq1
+
+pairUp sq = S.zip sq (sTail sq)
+
+-- A concatenate function; it is described by the recurrence:
+--
+-- T(n, k) = 2T(n/2, k) + log(kn/2)
+--
+-- when running sequentially and
+--
+-- T(n, k) = T(n/2, k) + log(kn/2)
+--
+-- where k is the maximum length of a subentry,
+--
+-- when running in parallel. Consider splitting an array into c pieces
+-- of roughly n/c each. The former recurrence solves as O(n/c log^2 (n/c));
+-- the latter as O(log^2 c). Therefore the function runs in
+-- O(n/c log^2 n) time [provided c <= n].
+fastConcat :: (t -> S.Seq u) -> S.Seq t -> S.Seq u
+fastConcat f sq = case S.length sq of
+	0 -> S.empty
+	1 -> f (sHead sq)
+	n -> let
+		(sq1, sq2) = S.splitAt (n `div` 2) sq
+		cc1 = fastConcat f sq1
+		cc2 = fastConcat f sq2 in
+		(cc1 `par` cc2) `pseq` (cc1 S.>< cc2)
+
+data Equal t u where
+	Equal :: Equal t t
+
+reassociate :: (Category a) => Structural a u v -> Either (Equal t u) (Structural a t u) -> Structural a t v
+reassociate (Comp a Id) = reassociate a
+reassociate (Comp a a2) = reassociate a . Right . reassociate a2
+reassociate a = either (\Equal -> a) (a.)
+
+-- | Obtain a 'Structural' program from an 'A' program.
+unA (A f) = f id
+
+-- | Obtain a 'Structural' program but postcompose with another program. 
+unA' :: A a u v -> Structural a t u -> Structural a t v
+unA' (A f) = f
+
+mapA' :: (ArrowChoice a) => A a t u -> A a (ArrC t) (ArrC u)
+mapA' (A f) = mapA (f id)
+
+liftA :: (Category a) => a t u -> A a t u
+liftA a = A (\a2 -> case a2 of
+	Comp (Lift a2) a3 -> Comp (Lift (a . a2)) a3
+	_ -> Lift a . a2)
+
+pack :: (Category a) => A a (ArrC (ArrC t)) (ArrC t)
+pack = A (\a -> case a of
+	Comp (Map (Comp (Map a) a2)) a3 -> Map a . unA' pack (Map a2 . a3)
+	Comp (Map (Map a)) a2 -> Map a . unA' pack a2
+	Comp (Map (Comp Pack a)) a2 -> unA' pack (unA' pack (Map a . a2))
+	Comp (Map Pack) a2 -> unA' pack (unA' pack a2)
+	Comp Unpack a2 -> a2
+	_ -> Pack . a)
+
+flatten :: Structural a t u -> Bool
+flatten (Comp a a2) = flatten a || flatten a2
+flatten Id = False
+flatten Unpack = False
+flatten Pack = False
+{-flatten Zip = False
+flatten Unzip = False-}
+flatten Separate = False
+flatten Combine = False
+flatten _ = True
+
+{-flatCounts :: (ArrowChoice a) => A a ((t, [Int]), [Int]) (ArrC (ArrC (t, [Int]), [Int]))
+flatCounts = zipA .
+	(splitA
+	. (mapA' (fstA . fstA &&& (arr (uncurry drop) . (sndA . fstA &&& sndA)))
+		. countA
+		. ((fstA . fstA &&& arr length . sndA) &&& arr (uncurry (flip (++))) . (sndA . fstA &&& sndA))
+		&&& arr (\(ls, ls2) -> let n = product ls in newArray [0,n..n*product ls2]) . (sndA . fstA &&& sndA))
+	&&& mapA' sndA . countA)-}
+
+-- | Mapping is the primary way of constructing nested data parallel programs.
+--   It applies an (arrow) transformation to each element of an array
+--   uniformly. A form of flattening transformation is applied to nested
+--   maps (following the NESL paper). The flattening transformation converts
+--   two levels of 'Map' into one level.
+mapA :: (ArrowChoice a) => Structural a t u -> A a (ArrC t) (ArrC u)
+mapA (Map a) | flatten a = A (\a2 -> case a2 of
+	Comp Unpack a3 -> Unpack . unA' (mapA a) a3
+	Comp Split a3 -> Split . unA' (first (mapA' (mapA a))) a3
+	Comp ClearMarks a3 -> ClearMarks . unA' (mapA' (mapA a)) a3
+	_ -> Unpack . unA' (mapA a) (unA' pack a2))
+mapA (Product a a2) = A (\a3 -> case a3 of
+	Comp Count a4 -> Comp (Map (Product Id a2)) (unA' (countA . first (A (Comp a))) a4)
+	Comp ClearMarks a4 -> ClearMarks . unA' (mapA (Product a a2)) a4
+	Comp (Map (Product a4 a5)) a6 -> unA' (mapA (Product (a . a4) (a2 . a5))) a6
+	Comp (Map (Comp (Product a4 a5) a6)) a7 -> unA' (mapA (Product (a . a4) (a2 . a5) . a6)) a7
+	_ -> Map (Product a a2) . a3)
+mapA (Comp a a2) = mapA a . mapA a2
+mapA Id = id
+-- mapA (Product a a2) = zipA . (mapA a *** mapA a2) . unzipA
+mapA Unpack = A (\a -> case a of
+	Comp Unpack a -> Unpack . (Unpack . a)
+	Comp (Map (Comp Pack a)) a2 -> Map a . a2
+	Comp (Map Pack) a -> a
+	Comp ClearMarks a3 -> ClearMarks . unA' (mapA Unpack) a3
+	_ -> Map Unpack . a)
+mapA a = A (\a2 -> case a2 of
+	Comp (Map a2) a3 -> Comp (Map (reassociate a (Right a2))) a3
+	Comp ClearMarks a3 -> ClearMarks . unA' (mapA a) a3
+	_ -> Comp (Map a) a2)
+
+scrubIds (Comp Id x) = scrubIds x
+scrubIds x = x
+
+instance (Category a) => Category (A a) where
+	id = A (\a -> a)
+	A f . A g = A (f . scrubIds . g)
+
+instance (ArrowChoice a) => Arrow (A a) where
+	arr = liftA . arr
+	A f *** A g = A (\a -> case a of
+		Comp (Product a2 a3) a4 -> Product (f a2) (g a3) . a4
+		_ -> Product (f id) (g id) . a)
+	first a = a *** id
+	second a = id *** a
+	a &&& a2 = (a *** a2) . dupA
+
+instance (ArrowChoice a) => ArrowChoice (A a) where
+	a +++ a2 = A (\a3 -> case a3 of
+		Comp Combine a3 -> Combine . unA' (mapA (unA a) *** mapA (unA a2)) a3
+		_ -> Combine . unA' (mapA (unA a) *** mapA (unA a2)) (Separate . a3))
+	left a = a +++ id
+	right a = id +++ a
+
+instance Show (Structural a t u) where
+	showsPrec prec (Map a) = ("Map " ++) . showParen (prec==11) (showsPrec 11 a)
+	showsPrec _ (Comp a a2) = showsPrec 11 a . (" . "++) . showsPrec 11 a2
+	showsPrec prec (Product a a2) = showParen (prec>=3) (showsPrec 3 a . (" *** "++) . showsPrec 3 a2)
+	showsPrec _ Count = ("Count"++)
+	showsPrec _ Index = ("Index"++)
+	showsPrec _ Split = ("Split"++)
+	showsPrec _ ClearMarks = ("Clr"++)
+	showsPrec _ Pack = ("Pk"++)
+	showsPrec _ Unpack = ("Unpk"++)
+	showsPrec _ Separate = ("Sep"++)
+	showsPrec _ Combine = ("Comb"++)
+	showsPrec _ Dup = ("Dup"++)
+	showsPrec _ Fst = ("Fst"++)
+	showsPrec _ Snd = ("Snd"++)
+	showsPrec _ Id = ("Id"++)
+	showsPrec _ _ = ("_"++)
+
+instance (Category a) => Category (Structural a) where
+	id = Id
+	(.) = Comp
+
+mirror ei = either Right Left ei
+
+splitOff :: (ArrowChoice a) => A a ((t1, t2), u) ((t1, u), (t2, u))
+splitOff = first fstA &&& first sndA
+
+assoc :: (ArrowChoice a) => A a ((t, u), v) (t, (u, v))
+assoc = fstA . fstA &&& (sndA . fstA &&& sndA)
+
+-- | Access one index of an array.
+indexA :: (ArrowChoice a) => A a (ArrC t, Int) t
+indexA = A (\a -> case a of
+	Comp (Product (Map a) a2) a3 -> a . unA' indexA (Product Id a2 . a3)
+	-- Comp (Product Zip a) a2 -> unA' ((indexA *** indexA) . splitOff) (second a . a2)
+	Comp (Product Count a) a2 -> unA' (fstA . fstA &&& arr (\(ns, i) -> snd (mapAccumL divMod i ns)) . (sndA . fstA &&& sndA)) (Product Id a . a2)
+	_ -> Index . a)
+
+-- | An operation analogous to 'zip', 'zipA' combines two packed arrays into a single array
+-- element by element.
+zipA :: (ArrowChoice a) => A a (ArrC t, ArrC u) (ArrC (t, u))
+zipA = id &&& arr (\(ar, ar2) -> (uncurry subtract (bounds (project ar)) `min` uncurry subtract (bounds (project ar2))) + 1)
+	>>> countA'
+	>>> mapA' (splitOff >>> indexA *** indexA)
+
+-- | 'unzipA' and 'zipA' are inverses.
+unzipA :: (ArrowChoice a) => A a (ArrC (t, u)) (ArrC t, ArrC u)
+unzipA = mapA' fstA &&& mapA' sndA
+
+-- | Concatenation flattens out nested layers of arrays. The key operation used to implement
+-- is erasing marks; erasing marks throws away the structure that would delineate the
+-- edges of arrays; effectively flattening them into one array. The operation is divided
+-- into packing and erasing marks, in the hope that the packing stage will fuse with an adjacent 'unpack'.
+concatA :: (Category a) => A a (ArrC (ArrC t)) (ArrC t)
+concatA = A (\a -> case a of
+	Comp Split a2 -> unA' fstA a2
+	_ -> Comp ClearMarks a) . pack
+
+forcePair (x, y) = x `seq` y `seq` (x, y)
+
+-- | Supplies an array of a repeated value paired with the index of each element.
+-- Arguably adjacent 'countA's should fuse; however this is hard to implement, so I
+-- have opted to provide a more powerful 'countA' that works on arrays of indices;
+-- it generates arrays of indices lexicographically ordered.
+countA :: (ArrowChoice a) => A a (t, [Int]) (ArrC (t, [Int]))
+countA = A(Comp Count)
+{- (\a -> case a of
+	Comp (Product Count a2) a3 -> unA' flatCounts (unA' (second (A (Comp a2))) a3)
+	Comp (Product (Comp a2 Count) a3) a4 -> unA' (mapA' (first (A (Comp a2))) . flatCounts . second (A (Comp a3))) a4
+	Comp (Product (Comp Count a2) a3) a4 -> unA' flatCounts (unA' (A (Comp a2) *** A (Comp a3)) a4)
+	Comp (Product (Comp a2 (Comp Count a3)) a4) a5 -> unA' (mapA' (first (A (Comp a2))) . flatCounts . (A (Comp a3) *** A (Comp a4))) a5
+	_ -> Comp Count a)-}
+
+countA' :: (ArrowChoice a) => A a (t, Int) (ArrC (t, Int))
+countA' = second (arr return) >>> countA >>> mapA' (second (arr head))
+
+-- | Replacements for common arrow functions make fusing work better.
+dupA :: (Category a) => A a t (t, t)
+dupA = A (Dup .)
+
+fstA :: (Category a) => A a (t, u) t
+fstA = A (\a -> case a of
+	Comp Dup a -> a
+	Comp (Product Id a) a2 -> Fst . (Product Id a . a2)
+	Comp (Product a Id) a2 -> a . unA' fstA a2
+	Comp (Product a a2) a3 -> a . unA' fstA (Product Id a2 . a3) -- Due to effects, cannot omit to do any operations
+	_ -> Fst . a)
+
+sndA :: (Category a) => A a (t, u) u
+sndA = A (\a -> case a of
+	Comp Dup a -> a
+	Comp (Product a Id) a2 -> Snd . (Product a Id . a2)
+	Comp (Product Id a) a2 -> a . unA' sndA a2
+	Comp (Product a a2) a3 -> a2 . unA' sndA (Product a Id . a3)
+	_ -> Snd . a)
+
+-- Runs in O(log^2(n)) time in the number of elements.
+binarySearch :: (Ord t) => t -> S.Seq t -> Int
+binarySearch x sq = recurse 0 (S.length sq) sq where
+	recurse off sz sq = if sz <= 1 then
+			off
+		else let
+			sz' = sz `div` 2
+			(sq1, sq2) = S.splitAt sz' sq
+			y S.:< _ = S.viewl sq2 in
+			if x < y then
+				recurse off sz' sq1
+			else
+				recurse (off + sz') (sz - sz') sq2
+
+packImpl (ArrC ar fr) = ArrC
+	(arr_concF (\(_, i) -> let
+		j = binarySearch i fr''
+		i2 = S.index fr'' j
+		ArrC ar' _ = ar ! j in
+		ar' ! (i-i2))
+		((), sz))
+	fr'
+	where
+	fr' = S.fromList $ snd $ mapAccumL (\i (ArrC ar fr) -> let j = i + rangeSize (bounds ar) in (j, Node i (fastConcat ((return $!) . fmap (+i)) fr))) 0 $ elems ar ++ [ArrC (newArray []) S.empty]
+	fr'' = fmap (\(Node i _) -> i) fr'
+	_ S.:> sz = S.viewr fr''
+
+unpackImpl (ArrC ar fr) = fastConcat
+	(\(Node j fr2, Node k _) -> return $! ArrC (ixmap (0, k-j-1) (+j) ar) (fastConcat ((return $!) . fmap (subtract j)) fr2))
+	(pairUp fr)
+
+-- | An evaluator for 'Structural' arrows. A structural arrow may be obtained from an 'A' arrow
+-- by either 'unA' or 'unA''.
+--
+-- Discussion of complexity bounds for various operations [these are provided c <= k]:
+--
+-- * Cost of 'ClearMarks' is O(k/c log^3(k)) in the number of subelements k.
+--
+-- * Cost of 'Pack' and 'Unpack' is O(k/c log^3(k) + k) in the number of subelements k.
+-- 'Pack' is O(n) in the worst case in the number of spine elements n.
+--
+-- * 'Map' costs O(f) assuming unlimited capabilities where 'a' runs in O(f) time.
+--
+-- * 'Combine' and 'Separate' are both O(1).
+eval0 :: (Concurrent a, Strict a, ArrowChoice a, ?seq :: Bool, ?pool :: BoxedThreadPool) => Structural a t u -> a t u
+eval0 Count = id &&& arr(snd>>>product) >>> arr_concF (arr (\((x, ns), i) -> (x, snd (mapAccumL divMod i ns)))) >>> arr inject
+eval0 Index = arr (\(ArrC ar _, i) -> ar ! i)
+eval0 ClearMarks =
+	arr (\(ArrC ar fr) ->
+		ArrC ar (fastConcat id (fmap (\(Node _ fr) -> fr) fr)))
+eval0 (Map a) = (arr (\(ArrC ar _) -> (ar, uncurry subtract (bounds ar) + 1)) >>> arr_concF (arr (uncurry (!)) >>> eval0 a)) &&& arr (\(ArrC _ fr) -> fr) >>> arr (uncurry ArrC)
+eval0 Split = undefined
+eval0 Pack = arr packImpl
+eval0 Unpack = arr (inject . newArray . toList . unpackImpl)
+eval0 Separate = arr (\ei -> ((,) $! either (\x -> inject $ newArray [x]) (\_ -> inject $ newArray []) ei) $! either (\_ -> inject $ newArray []) (\x -> inject $ newArray [x]) ei)
+eval0 Combine = arr (\(ar, ar2) -> let
+	a1 = project ar
+	a2 = project ar2 in
+	if uncurry subtract (bounds (project ar)) == 0 then Left $! a1 ! 0 else Right $! a2 ! 0)
+eval0 (Comp a a2) = force (eval0 a) . eval0 a2
+eval0 Id = id
+eval0 (Lift a) = a
+eval0 (Product a a2) = arr forcePair . force (second (eval0 a2)) . arr forcePair . first (eval0 a)
+eval0 Dup = arr (\x -> forcePair (x, x))
+eval0 Fst = arr fst
+eval0 Snd = arr snd
+
+-- | Evaluates arrows.
+eval a = let ?seq = True in eval0 a
+
+instance (Concurrent a, Strict a, ArrowChoice a, ArrowApply a) => ArrowApply (A a) where
+	app = first (arr (eval . unA)) >>> liftA app where
+		?pool = BoxedThreadPool NoPool
+
+--------------------------------
+-- Examples using NDP techniques
+
+checkThreats n positions = n `elem` positions -- Check if there is a piece on the row
+	|| n `elem` zipWith (-) positions [1..] -- ... the diagonal
+	|| n `elem` zipWith (+) positions [1..] -- ... or the other diagonal
+
+checkThreats2 positions = or [ checkThreats n tl | n:tl <- tails positions ]
+
+nQueensImpl :: A (->) ((), [Int]) (ArrC [Int])
+nQueensImpl = countA >>> mapA' (arr (\(_, soln) -> if checkThreats2 soln then inject (newArray []) else inject (newArray [soln])))
+	>>> concatA
+
+nQueens n = arr (\() -> ((), replicate n n)) >>> nQueensImpl
+
+-------------------------------
+
+sorting :: (Ord t) => Int -> A (->) (ArrC t) (ArrC t)
+sorting depth | depth <= 0 = arr (inject . newArray . sort . elems . project)
+sorting depth = arr (\x -> if uncurry subtract (bounds (project x)) <= 0 then Left x else Right x)
+	>>> id
+		||| (arr (\ar -> let
+			x:xs = elems (project ar)
+			(bef, aft) = partition (<x) xs in
+			((inject (newArray bef), inject (newArray aft)), x))
+			>>> first (s *** s)
+			>>> arr (\((bef, aft), x) -> inject (newArray (elems (project bef) ++ x : elems (project aft)))))
+	where s = sorting (pred depth) -- Memoize the answer
+-- In order to make this recursive function a finite data structure, there is a depth limit
+-- parameter, beyond which the standard 'sort' takes over.
+
+-------------------------------
+
+permute :: A (->) (ArrC Int) (ArrC Int)
+permute = arr (\ar -> (ar, [uncurry subtract (bounds (project ar)) + 1])) >>> countA >>> mapA' (second (arr head) >>> indexA)
+
+-------------------------------
+
+dotProduct :: (Num t) => A (->) (ArrC t, ArrC t) t
+dotProduct = proc (v1, v2) -> do
+	vzip <- zipA -< (v1, v2)
+	vdots <- mapA' (arr (uncurry (*))) -< vzip
+	returnA -< sum $ elems $ project vdots
+
+transpose' :: A (->) (ArrC (ArrC t)) (ArrC (ArrC t))
+transpose' = proc m -> do
+	firstrow <- indexA -< (m, 0)
+	rows <- countA -< (m, [uncurry subtract (bounds (project firstrow)) + 1])
+	-- Build skeleton of result array
+	rowcols <- mapA' (proc (m, [ii]) -> do
+		v <- countA -< ((m, ii), [uncurry subtract (bounds (project m)) + 1])
+		mapA' (proc ((m, ii), [jj]) -> returnA -< (m, (ii, jj))) -< v) -< rows
+	-- Build result
+	mapA' (mapA' (proc (m, (ii, jj)) -> do
+		v <- indexA -< (m, jj)
+		indexA -< (v, ii)))
+		-< rowcols

@@ -1,202 +1,195 @@-{-# LANGUAGE Trustworthy, GADTs, ParallelListComp, Arrows, ImplicitParams, ScopedTypeVariables #-}
+{-# LANGUAGE Trustworthy, GADTs, ParallelListComp, Arrows, ImplicitParams, ScopedTypeVariables, FlexibleInstances #-}
 
--- | Automatic deadlock prevention.
---
--- Automatic deadlock detection is inefficient, and computations cannot be rolled
--- back or aborted in general.
---
--- Instead, I prevent deadlocks before they happen.
-module Control.CUtils.Deadlock (Res(Lift, Acq, Rel, Fork, Plus, Id), liftK, lft, acq, rel, fork, run) where
+-- | Automatic deadlock avoidance.
+module Control.CUtils.Deadlock (AbstractLock(..), BoxedAbstractLock(..), LockSafetyException(LockTakenTwice, LockNotDeclared), acquire, release, test) where
 
-import Control.Category
-import Control.Arrow
 import Control.Monad
-import Data.Map (Map)
+import Control.Monad.Loops
+import Control.Concurrent
+import Control.Concurrent.STM
+import Control.Concurrent.MVar
+import qualified Control.Concurrent.STM.Map as MS
 import Data.List (inits, tails, elemIndex, deleteBy)
-import Data.Array.IO (IOArray, newArray_, writeArray)
-import Data.Array.Unsafe
-import Data.Array
 import Data.Maybe
 import Data.Function (on)
+import Data.Typeable
 import Data.BellmanFord
-import qualified Data.Map as M
+import Data.Hashable
+import qualified Data.HashTable.IO as H
 import System.IO.Unsafe
 import Unsafe.Coerce
-import Control.Concurrent
 import Control.CUtils.Conc
-import Control.CUtils.StrictArrow
-import Prelude hiding (id, (.))
-
--- | The typical sequence that produces a deadlock is as follows:
---
--- (1) Thread 1 acquires lock A
---
--- (2) Thread 2 acquires lock B
---
--- (3) Thread 1 tries to acquire B
---
--- (4) Thread 2 tries to acquire A
---
--- Deadlock.
---
--- Standard deadlock detection intervenes after (4) has occurred.
--- I intervene in a lock acquisition that is followed
--- by an unsafe schedule (here at (2)). I suspend thread 2
--- until a safe schedule is guaranteed -- in this case until
--- thread 1 relinquishes lock A.
---
--- The Res arrow.
---
--- Computations are built with these constructors (and the arrow
--- interface). Pieces of the arrow that hold locks have to be finitely examinable,
--- Locks have to be used with the Acq and Rel constructors.
-data Res t u where
-	Lift :: Kleisli IO t v -> Res v u -> Res t u
-	Acq :: MVar () -> Res t u -> Res t u -- acquire a lock
-	Rel :: MVar () -> Res t u -> Res t u -- release a lock
-	Fork :: Res t () -> Res t u -> Res t u -- fork a thread
-	Plus :: Res t v -> Res u v -> Res (Either t u) v -- choice
-	Id :: Res t t
-
-liftK f = Lift (Kleisli f) Id
-
-lft m = Lift (Kleisli (const m))
-
-acq m = Acq m Id
-
-rel m = Rel m Id
-
-fork a = Fork a
+import Control.Exception
+import GHC.Conc
 
-instance Category Res where
-	id = Id
-	a . Lift k a2 = Lift k (a . a2)
-	a . Acq m a2 = Acq m (a . a2)
-	a . Rel m a2 = Rel m (a . a2)
-	a . Fork a2 a3 = Fork a2 (a . a3)
-	a . Plus a2 a3 = Plus (a . a2) (a . a3)
-	a . Id = a
+class AbstractLock l where
+	lock :: l -> IO ()
+	unlock :: l -> IO ()
 
-instance Arrow Res where
-	arr f = Lift (arr f) Id
-	first (Lift k a) = Lift (first k) (first a)
-	first (Acq m a) = Acq m (first a)
-	first (Rel m a) = Rel m (first a)
-	first (Fork a a2) = Fork (a . arr fst) (first a2)
-	first Id = Id
+instance AbstractLock (MVar ()) where
+	lock m = takeMVar m
+	unlock m = void (tryPutMVar m ())
 
-instance ArrowChoice Res where
-	left a = Plus (arr Left . a) (arr Right)
+-- | An automatic deadlock avoidance algorithm prevents deadlocks from occurring,
+--   by dynamically controlling the way threads use locks, to prevent the appearance
+--   of cycles in the ownership graph.
+--
+--   Another way of stating the intuition is: the evolution of multiple locks
+--   can be visualized as a multi-dimensional space, with the regions in which
+--   locks are held coloured black. This algorithm attempts to cover up
+--   the concave spaces in these regions, in which the evolution can get stuck.
+--
+--   It is important to ensure that the management of the ownership graph is
+--   fast. There are probably a lot of ways to do this; the one used here is
+--   to use a concurrent hash table; and only process nodes that are in the
+--   same connected component as the node in question. This at least gives
+--   a system a performance related to the size of its interacting components.
 
-unsafeFreeze' :: IOArray Int e -> IO (Array Int e)
-unsafeFreeze' = unsafeFreeze
+reachable :: (Hashable t, Eq t, Show t) => MS.Map t [(u, [t])] -> t -> STM (H.BasicHashTable t [t])
+reachable mp from = unsafeIOToSTM H.new>>= \tabu->recurse [from] tabu>>return tabu where
+	recurse ls tabu =mapM_
+		(\x->do
+		may <- unsafeIOToSTM(H.lookup tabu x)
+		unless(isJust may)$do
+			ls' <- liftM(maybe [] (concatMap snd))$MS.lookup x mp
+			unsafeIOToSTM$H.insert tabu x ls'
+			recurse ls' tabu)
+		ls
 
-instance Concurrent Res where
-	-- This is a cheesy reimplementation of the stuff in .Conc, so that we
-	-- can use (and examine) the 'Fork' primitive.
-	arr_concF_ mnds = proc (parm, n) -> do
-		sem <- Lift (Kleisli $ const $ newQSem 0) Id -< ()
-		recurse -< (sem, parm, n)
-		Lift (Kleisli $ \(sem, n) -> sequence_ (replicate n (waitQSem sem))) Id -< (sem, n) where
-		recurse = proc (sem, parm, n) -> if n <= 0 then
-				returnA -< ()
-			else
-				(Fork (proc (sem, parm, n) -> do
-					mnds -< (parm, n)
-					Lift (Kleisli signalQSem) Id -< sem)
-					recurse) -< (sem, parm, pred n)
-	arr_concF mnds = proc (parm, n) -> do
-		ar <- Lift (Kleisli newArray_) Id -< (0, n-1)
-		arr_concF_ (proc ((ar, parm), n) -> do
-			x <- mnds -< (parm, n)
-			Lift (Kleisli $ \(n, x, ar) -> writeArray ar n x) Id -< (n, x, ar))
-			-< ((ar, parm), n)
-		Lift (Kleisli unsafeFreeze') Id -< ar
-	arr_oneOfF mnds = let ?seq = False in arr_concF mnds >>> arr (! 0)
+data BoxedAbstractLock where
+	BoxedAbstractLock :: (AbstractLock l, Eq l, Hashable l, Typeable l) => l -> BoxedAbstractLock
 
-instance Strict Res where
-	force = Lift (force id)
+instance Eq BoxedAbstractLock where
+	BoxedAbstractLock l == BoxedAbstractLock l2 = maybe False (l==) (cast l2)
+instance AbstractLock BoxedAbstractLock where
+	lock (BoxedAbstractLock l) = lock l
+	unlock (BoxedAbstractLock l) = unlock l
+instance Show BoxedAbstractLock where
+	showsPrec _ (BoxedAbstractLock _) = ("BoxedAbstractLock _"++)
+instance Hashable BoxedAbstractLock where
+	hashWithSalt x (BoxedAbstractLock l) = hashWithSalt x l
 
 -- For each thread, we need to track what resources it currently
 -- holds, and for each resource, the resources it may
 -- potentially acquire while holding that resource.
 
-resource :: MVar (Map ThreadId [(MVar (), [MVar ()])])
+resource :: MS.Map BoxedAbstractLock [(ThreadId,[BoxedAbstractLock])]
 {-# NOINLINE resource #-}
-resource = unsafePerformIO (newMVar M.empty)
-
--- A hazard is a HOLD-ACQUIRE cycle among threads.
--- We generate all sequences looking for a cycle.
+resource = unsafePerformIO$atomically MS.empty
 
-instance Ord (MVar t) where
-	x <= y = (unsafeCoerce x :: Int) <= (unsafeCoerce y :: Int)
+resourceThreads :: MS.Map ThreadId [(BoxedAbstractLock,[BoxedAbstractLock])]
+{-# NOINLINE resourceThreads #-}
+resourceThreads = unsafePerformIO$atomically MS.empty
 
 instance Show (MVar t) where
 	show x = show (unsafeCoerce x :: Int)
+instance Hashable (MVar t) where
+	hashWithSalt x m = hashWithSalt x(unsafeCoerce m :: Int)
 
--- If there is a hazard, returns a /guard/ for the hazard, i.e.
--- a lock which avoids the hazard.
-hazard mp m = cycles (M.fromList $ concatMap (\ls -> concatMap (\(x, ls2) -> map (\y -> ((x, y), ())) ls2) ls) $ M.elems mp) m
+-- If there is a HOLD-ACQUIRE cycle, find a lock which guards against this cycle.
+-- I.e. by the time the lock becomes free, the cycle may no longer exist.
+hazard m = reachable resource m>>=unsafeIOToSTM.H.toList>>= \ls->return$!cycles[((x,x2),())|(x, ls')<-ls,x2<-ls'] m
 
--- This is the static analysis bit.
-acquired :: Res t u -> MVar () -> [MVar ()]
-acquired (Lift _ a) m = acquired a m
-acquired (Acq m' a) m = m' : acquired a m
-acquired (Rel m' _) m | m' == m = []
-acquired (Rel _ a) m = acquired a m
-acquired (Fork a a2) m = acquired a m ++ acquired a2 m
-acquired (Plus a a2) m = acquired a m ++ acquired a2 m
-acquired Id _ = []
+data LockSafetyException = LockTakenTwice -- Lock taken twice (thread deadlocks with itself)
+	| LockNotDeclared -- Lock ordering improperly declared
+	| Abort !BoxedAbstractLock -- This exception never propagates out of library code.
+	deriving (Show, Typeable)
 
+instance Exception LockSafetyException
+
 insert x y ((x1, _):xs) | x == x1 = (x, y) : xs
-insert x y (pr:xs) = pr : insert x y xs
+insert x y (pr:xs) = ((:) $! pr) $! insert x y xs
 insert x y [] = [(x, y)]
 
--- | Use this to run computations built in the Res arrow.
-run :: Res t u -> t -> IO u
-run (Lift k a) x = runKleisli k x >>= run a
-run (Acq m a) x = do
+updateResource thd l possiblyAcq = do
+	may <- MS.lookup thd resourceThreads
+	let isDoubleTake = maybe False (\ls -> l `elem` map fst ls) may
+	when isDoubleTake(throwSTM LockTakenTwice)
+	let isPreDeclared = maybe True (\ls -> null ls || l `elem` concatMap snd ls) may
+	unless isPreDeclared(throwSTM LockNotDeclared)
+
 	-- Add this lock to held locks.
-	mp <- takeMVar resource
-	thd <- myThreadId
-	let mp' = M.alter (Just . insert m (acquired a m) . maybe [] id) thd mp
+	may2 <- MS.lookup l resource
+	let rtInsert = insert l possiblyAcq$maybe [] id may
+	(MS.insert thd $! rtInsert) resourceThreads
+	let rInsert = insert thd possiblyAcq$maybe [] id may2 
+	(MS.insert l $! rInsert) resource
 
-	-- Have to see if acquiring this lock creates a hazard
-	-- involving possibly acquired locks.
-	let may = hazard mp' m
-	maybe
-		(do
-			putMVar resource mp'
-			takeMVar m
-			run a x)
+	-- Have to see if acquiring this lock risks encountering a cycle
+	-- in the ownership graph.
+	lock <- hazard l
+	when(isJust lock)$throwSTM$!Abort$fromJust lock
+
+-- | Acquire a lock. In order to implement deadlock avoidance, the function 'acquire'
+-- requires that all locks a thread may take while holding the given lock are annotated
+-- in parameter 'possiblyAcq'.
+--
+-- While programs with locks have rare deadlock conditions, they have common lock
+-- use patterns in-thread. If we throw an exception whenever lock use patterns are not properly
+-- declared, all lock use patterns will show up in testing and can be annotated.
+--
+-- Complexity overview:
+--
+--   Let N = the number of locks.
+--
+--   Let K = the size of the largest directed component of the ownership graph.
+--
+--   Let C = the number of capabilities.
+--
+--   'acquire' runs in O(K log N + K^3/C) time [provided C <= K].
+acquire :: BoxedAbstractLock -> [BoxedAbstractLock] -> IO () 
+acquire l possiblyAcq = resourceThreads `seq` resource `seq` whileM_
+	(catch
+	(do
+	thd <- myThreadId
+	atomically(updateResource thd l possiblyAcq)
+	return False)
+	(\ex -> case ex of
 		-- Waits on the lock. This has the effect of denying service
 		-- to this thread until the hazard has passed.
-		(\m' -> do
-			putMVar resource mp
-			takeMVar m'
-			putMVar m' ()
-			run (Acq m a) x)
-		may
-run (Rel m a) x = do
-	putMVar m ()
+		Abort l' -> do{lock l';unlock l';return True}
+		_ -> throwIO ex))
+	(return ())
+	>>lock l
+
+-- | Release a lock so acquired.
+--
+--   'release' runs in O(log N) time.
+release :: BoxedAbstractLock -> IO ()
+release l = resourceThreads `seq` resource `seq` do
 	thd <- myThreadId
-	modifyMVar_ resource (return . M.adjust (deleteBy ((==) `on` fst) (m, [])) thd)
-	run a x
-run (Fork a a2) x = forkIO (run a x) >> run a2 x
-run (Plus a a2) ei = either (run a) (run a2) ei
-run Id x = return x
+	atomically$do
+		may <- MS.lookup thd resourceThreads
+		maybe
+			(return())
+			(\ls -> MS.insert thd(deleteBy((==)`on`fst) (l, []) ls) resourceThreads)
+			may
+		may2 <- MS.lookup l resource
+		maybe
+			(return())
+			(\ls -> MS.insert l(deleteBy((==)`on`fst) (thd, []) ls) resource)
+			may2
+	unlock l
 
--- This implements the example above, using the primitives of this library.
-test = do
-	m1 <- newMVar ()
-	m2 <- newMVar ()
-	run (fork (lft (print "Thd1 done") Id . rel m1 . rel m2 . acq m1 . lft (threadDelay 1000000) Id . acq m2)
-		(lft (print "Thd2 done") Id . rel m1 . rel m2 . acq m2 . lft (threadDelay 1000000) Id . acq m1))
-		()
+-- The dining philosophers problem
+philosopher n lfFork rtFork delay printL = whileM_
+	(return True)
+	(do
+	threadDelay (1000*delay)
+	modifyMVar_ printL$ \_->print$"Take left fork (" ++ show n ++ ")"
+	acquire lfFork [rtFork]
+	modifyMVar_ printL$ \_->print$"Take right fork (" ++ show n ++ ")"
+	acquire rtFork []
+	threadDelay (1000*delay)
+	release lfFork
+	release rtFork)
 
-test2 = do
-	m1 <- newMVar ()
-	m2 <- newMVar ()
-	let waltz = rel m1 >>> acq m1 >>> rel m2 >>> acq m2 >>> lft (threadDelay 500000) Id . waltz
-	run (fork (acq m1 >>> acq m2 >>> waltz) (lft (threadDelay 1000000) Id >>> acq m2 >>> lft (print "Done") Id >>> rel m2))
-		()
+-- | Test: The dining philosophers problem
+test = do
+	fork1 <- liftM BoxedAbstractLock (newMVar ())
+	fork2 <- liftM BoxedAbstractLock (newMVar ())
+	fork3 <- liftM BoxedAbstractLock (newMVar ())
+	printL <- newMVar ()
+	forkIO$philosopher 1 fork1 fork2 500 printL
+	forkIO$philosopher 2 fork2 fork3 90 printL
+	philosopher 3 fork3 fork1 1000 printL

@@ -0,0 +1,26 @@+{-# LANGUAGE Safe, ExistentialQuantification #-}
+
+module Control.CUtils.Dyn (Dyn, value, makeDyn, determineType) where
+
+import Data.Typeable
+
+data Dyn = forall t. (Eq t, Show t, Typeable t) => Dyn t deriving Typeable
+
+value :: (Typeable t) => Dyn -> Maybe t
+value (Dyn x) = cast x
+
+makeDyn :: (Eq t, Show t, Typeable t) => t -> Dyn
+makeDyn = Dyn
+
+determineType :: Dyn -> TypeRep
+determineType (Dyn x) = typeOf x
+
+instance Eq Dyn where
+	-- A notion of equality at multiple types considers two values to be equal
+	-- iff they have the same type, and are equal according to the equality test
+	-- at such type.
+	Dyn x1 == Dyn x2 = maybe False(==x2) (cast x1)
+
+instance Show Dyn where
+	-- Show instance passes through to that of the underlying type.
+	showsPrec prec (Dyn x) = showsPrec prec x

@@ -1,7 +1,7 @@ {-# LANGUAGE Trustworthy, DeriveDataTypeable #-}
 
 -- | Functional channels
--- | A channel data type which allows consumers to hold references to different points in a stream at the same time. Elements of a channel are kept alive only so long as there are references pointing before those elements. And producers on a channel are kept alive only so long as there are consumers.
+-- | A channel data type which allows consumers to hold references to different points in a stream at the same time. Elements of a channel are kept alive only so long as there are references pointing before those elements; producers on a channel are kept alive only so long as there are consumers.
 module Control.CUtils.FChan (Chan, listToChan, chanContents, DoneReadingException(..), takeChan, tryTakeChan, newChan, makeConsumer, dupChan) where
 
 import Control.Concurrent.MVar
@@ -55,7 +55,7 @@ 	putMVar vr2 chn
 	return (addChan vr2, chn)
 
--- | The first return value is a thunk that returns values from the channel successively, starting from the position of the parameter channel. The second thunk can be used to retrieve the position of the channel after all the reads made using the first thunk.
+-- | The first return value is a procedure that returns values from the channel successively, starting from the position of the parameter channel. The second thunk can be used to retrieve the position of the channel after all the reads made using the first thunk.
 makeConsumer chn = do
 	vr2 <- newMVar chn
 	return (modifyMVar vr2 (\chn -> do

@@ -1,358 +0,0 @@-{-# LANGUAGE CPP, ScopedTypeVariables #-}
-
--- | A channel module with transparent network communication.
-module Control.CUtils.NetChan (NetSend, NetRecv, localHost, newNetChan, newNetSend, newNetRecv, send, receive, recv, recvSend, sendRecv, recvRecv, activateSend, activateRecv, Auth, authServer, authClient, example) where
-
--- This module has a strategy for routing around dead nodes. See 'routeAround'.
-
-import System.IO
-import System.Process
-import Data.List (find, isPrefixOf, (\\))
-import Network
-import Network.Socket (socketToHandle, SockAddr(..))
-import Network.BSD
-import Control.Concurrent
-import Control.Monad
-import Data.ByteString.Lazy hiding (map, isPrefixOf, dropWhile, drop, head, split)
-import qualified Data.ByteString as B
-import Data.Binary
-import Data.Binary.Get
-import Data.Binary.Put
-import qualified Data.Map as M
-import Data.Maybe
-import Data.Char
-import Data.IORef
-import Data.Bits
-import Control.Exception
-import System.IO.Unsafe
-import Crypto.Hash.SHA512
-import Codec.Crypto.RSA.Pure
-import Crypto.Random
-import Reexport.Crypto.Random
-import Data.SecureMem
-import Foreign.Storable
-import Data.Tagged
-import Prelude hiding (lookup, length, splitAt, catch)
-
-import Control.CUtils.Split
-
-type Ident = ByteString
-
-{-# NOINLINE serverup #-}
-serverup = unsafePerformIO (newMVar False)
-
-{-# NOINLINE table #-}
-table :: MVar (M.Map Ident (ByteString -> IO ()))
-table = unsafePerformIO (newMVar (M.singleton empty (\_ -> return ())))
-
-data ChannelFibre = ChannelFibre (MVar Bool) Handle
-
-data NetSend t = NetSend HostName Ident (MVar [HostName]) (MVar [ChannelFibre])
-
-data NetRecv t = NetRecv Ident (NetSend t) (NetSend HostName) (Chan ByteString)
-
-instance Eq ChannelFibre where
-	ChannelFibre _ hdl == ChannelFibre _ hdl2 = hdl == hdl2
-
-instance Eq (NetSend t) where
-	NetSend _ ident _ _ == NetSend _ ident2 _ _ = ident == ident2
-
-instance Eq (NetRecv t) where
-	NetRecv ident _ _ _ == NetRecv ident2 _ _ _ = ident == ident2
-
-port = 2999
-
-getIPAddress :: String -> Word32
-getIPAddress ip = shiftL n4 24 .|. shiftL n3 16 .|. shiftL n2 8 .|. n1 where
-	[n1,n2,n3,n4] = map read $ split '.' ip
-
--- Hack - just gets the local IP address
-localHost = liftM (drop 39 . head . dropWhile (not . isPrefixOf "   IPv4") . lines) $ readProcess "ipconfig" [] []
-
--- The identifier of a channel is determined by the originating host and a host-unique serial number.
-identifier :: String -> Word32 -> Ident
-identifier ip entry = encode (entry, getIPAddress ip)
-
---- Channel creation.
-
--- | Creates a new channel, with receive and send ends.
-newNetChan :: (Binary t) => IO (NetRecv t, NetSend t)
-newNetChan = do
-	mp <- readMVar table
-	host <- localHost
-	let ident = identifier host (fromIntegral (M.size mp))
-	liftM2 (,) (__newNetRecv True Nothing ident) (__newNetSend True host ident)
-
-modifyIdent b ident = append (pack $ map (fromIntegral . ord) $ if b then "main" else "back") ident
-
-__emptyNetSend :: Bool -> NetSend HostName -> HostName -> Ident -> IO (NetSend t)
-__emptyNetSend b backDown hostName ident = do
-	let ident' = modifyIdent b ident
-
-	-- Create a back channel.
-	buffer <- newMVar []
-	-- Fill the buffer immediately, so this host gets the data before downstreams die.
-	if b then do
-			backR <- __newNetRecv False (Just backDown) ident
-			let loop = do
-				host <- recv backR
-				modifyMVar_ buffer (return . (host:))
-
-				loop
-			forkIO loop
-		else
-			return undefined
-
-	mvar <- newMVar []
-	return (NetSend hostName ident' buffer mvar)
-
-__addConnection s@(NetSend _ ident buffer mvar) hostName = do
-	mvar2 <- newMVar False
-
-	-- Open a TCPIP socket to send
-	hdl <- withSocketsDo $ connectTo hostName (PortNumber port)
-	hSetBuffering hdl (BlockBuffering (Just 1024))
-
-	-- Send identifier
-	hPut hdl ident
-
-	-- Send list of upstreams
-	upstreams <- readMVar buffer
-	let bs = encode (hostName : upstreams)
-	hPut hdl $ encode $ length bs
-	hPut hdl bs
-
-	hFlush hdl
-
-	modifyMVar_ mvar (return . (ChannelFibre mvar2 hdl:))
-
-__newNetSend b hostName ident = do
-	s <- if b then
-			__emptyNetSend False undefined "" ident
-		else
-			return undefined
-	s <- __emptyNetSend b s hostName ident
-	__addConnection s hostName
-	return s
-
--- | Open a channel to another host
-newNetSend hostName = __newNetSend True hostName (identifier hostName 0)
-
-readLoop f hdl = do
-	n <- liftM decode (hGet hdl 8)
-	bs <- hGet hdl n
-	f bs
-	readLoop f hdl
-
-server socket = withSocketsDo $ do
-	-- Accept loop
-	let loop = do
-		(hdl, host, _) <- accept socket
-		ident <- hGet hdl 12
-		may <- liftM (M.lookup ident) $ readMVar table
-		maybe
-			(hPutStrLn stderr ("The host " ++ host ++ " used an invalid Ident: " ++ show ident))
-			(\f -> forkIO (withSocketsDo (readLoop f hdl)) >> return ())
-			may
-		loop
-
-	loop
-
-__newNetRecv :: (Binary t) => Bool -> Maybe (NetSend t) -> Ident -> IO (NetRecv t)
-__newNetRecv b may ident = do
-	chan <- newChan
-
-	-- Create a back channel
-	--
-	-- The downstream of the back channel is the upstream of the main channel.
-	backS <- if b then
-			__emptyNetSend False undefined "" ident
-		else
-			return undefined
-
-	downstream <- maybe
-		(__emptyNetSend b backS "" ident)
-		return
-		may
-
-	let ident' = modifyIdent b ident
-
-	gotUpstreams <- newIORef False
-	let listener bs = do
-		got <- readIORef gotUpstreams
-		if got then do
-				writeChan chan bs
-
-				-- Send the value to downstream receive ends.
-				__send downstream bs
-			else do
-				writeIORef gotUpstreams True
-				let x:xs = decode bs
-				when b $ do
-					let NetSend _ _ buffer _ = backS
-					modifyMVar_ buffer (\_ -> return xs)
-					__addConnection backS x
-
-	-- Put a listener in the table.
-	modifyMVar_ table (return . M.insert ident' listener)
-
-	-- Start the server singleton
-	modifyMVar_ serverup (\b -> unless b (withSocketsDo $ listenOn (PortNumber port) >>= forkIO . server >> return ()) >> return True)
-
-	return (NetRecv ident' downstream backS chan)
-
--- | Creates a receive end of this host's channel. Type unsafe!
-newNetRecv :: (Binary t) => IO (NetRecv t)
-newNetRecv = localHost >>= \host -> __newNetRecv True Nothing (identifier host 0)
-
---- Send and receive.
-
--- If send fails, route around the node.
-routeAround fib s@(NetSend _ ident buffer mvar) = do
-	hosts <- modifyMVar buffer (\ls -> return ([], ls))
-	mapM_ (__addConnection s) hosts
-	modifyMVar_ mvar (return . (\\[fib]))
-
-__send snd@(NetSend _ ident _ mvar) s = readMVar mvar >>= mapM_ (\fib@(ChannelFibre mvar hdl) -> do
-	b <- modifyMVar mvar (\b ->
-		s `seq` catch (hPut hdl (encode (length s)) >> hPut hdl s) (\(_ :: SomeException) -> routeAround fib snd >> __send snd s)
-		>> return (True, b))
-	-- Buffering
-	unless b $ void $ forkIO $ do
-		threadDelay 100000
-		modifyMVar_ mvar (\_ -> return False)
-		catch (hFlush hdl) (\(_ :: SomeException) -> routeAround fib snd >> __send snd s))
-
--- | Sends something on a channel.
-send :: (Binary t) => NetSend t -> t -> IO ()
-send snd x = __send snd (encode x)
-
-receive (NetRecv _ _ _ chan) = readChan chan
-
--- | Receives something from a channel.
-recv :: (Binary t) => NetRecv t -> IO t
-recv r = liftM decode $ receive r
-
---- Sending and receiving channels.
-
--- | Receives the send end of a channel, on a channel.
-recvSend r = recv r >>= activateSend
-
--- | Sends the receive end of a channel, on a channel.
-sendRecv s@(NetSend hostName _ _ mvar) r@(NetRecv ident s2 backS _) = do
-	send s r
-
-	-- This node is now responsible for passing on messages to the destination(s).
-	__addConnection s2 hostName
-
-	-- Inform upstream of this
-	send backS hostName
-
--- | Receives the receive end of a channel, on a channel.
-recvRecv r = recv r >>= activateRecv
-
---- Channel data utilities.
-
-instance Binary (NetSend t) where
-	put (NetSend hostName ident _ _) = put hostName >> put ident
-	get = liftM2 (\x y -> NetSend x y undefined undefined) get get
-
-instance Binary (NetRecv t) where
-	put (NetRecv ident _ _ _) = put ident
-	get = liftM (\x -> NetRecv x undefined undefined undefined) get
-
-activateSend :: NetSend t -> IO (NetSend t)
-activateSend (NetSend hostName ident _ _) = __newNetSend True hostName ident
-
-activateRecv :: (Binary t) => NetRecv t -> IO (NetRecv t)
-activateRecv (NetRecv x _ _ _) = __newNetRecv True Nothing x
-
-repeatM m = m >> repeatM m
-
-data Auth t = Auth B.ByteString B.ByteString ByteString
-
-putLazy = mapM_ putByteString . toChunks
-
-instance Binary (Auth t) where
-	put (Auth b b2 b3) = putByteString b >> putByteString b2 >> putLazy b3
-	get = liftM3 Auth (getByteString 64) (getByteString 100) getRemainingLazyByteString
-
-instance CryptoRandomGen EntropyPool where
-	newGen _ = error "newGen: unsupported on SystemRNG"
-	genSeedLength = Tagged maxBound
-	genBytes l g = entropy `seq` Right (readSecureMem entropy, g) where
-		entropy = grabEntropy l g
-	reseed _ = Right
-	reseedInfo _ = Never
-	reseedPeriod _ = Never
-
-readSecureMem mem = unsafePerformIO $ withSecureMemPtrSz mem $ \n p -> liftM B.pack $ mapM (peekByteOff p) [0..n-1]
-
--- | Remote exercise of authority. Commands are transmitted in the clear,
---   but authenticated.
---
---   auth - The authority to be served (runs on a separate thread).
---
---   r - The receive end from the host.
---
---   s - The send end to the host.
---
---   publicKey - The public key of the intended recipient.
-authServer :: (Binary t) => (t -> IO ()) -> NetRecv (Auth t) -> NetSend ByteString -> PublicKey -> IO ()
-authServer auth r s publicKey = do
-	pool <- createEntropyPool
-
-	-- Engage in crypto to agree on a random certificate.
-	(cert, g) <- either throwIO return $ genBytes 100 pool
-	cert <- return $ fromChunks [cert]
-	let ei = encrypt g publicKey cert
-	(enc, _) <- either throwIO return ei
-	send s enc
-
-	-- Accept requests.
-	forkIO $ repeatM $ do
-		command <- receive r
-		let (tk, dr) = splitAt 64 command
-		let x = runGet (getByteString 100 >> get) dr
-		-- Check the hash before approving the command.
-		when (fromChunks [hashlazy $ append cert dr] == tk) $ auth x
-
-	return ()
-
--- | privateKey - The private key for this host.
---
---   Returns a function that can be used to send messages.
-authClient :: (Binary t) => NetRecv ByteString -> NetSend (Auth t) -> PrivateKey -> IO (t -> IO ())
-authClient r s privateKey = do
-	-- Decrypt the certificate.
-	enc <- recv r
-	let ei = decrypt privateKey enc
-	cert <- either throwIO return ei
-
-	pool <- createEntropyPool
-	return $ \x -> do
-		salt <- grabEntropyIO 100 pool
-		salt <- return $ readSecureMem salt
-		let enc = encode x
-		send s $ Auth (hashlazy $ cert `append` fromChunks [salt] `append` enc) salt enc
--- The format of an authenticated record is:
--- 
--- * An eight-byte record length, in bytes
---
--- * A 64-byte hash
---
--- * A 100-byte salt
---
--- * The remainder of the record contains the data
-
-example = do
-	pool <- createEntropyPool
-	let Right (pub, priv, _) = generateKeyPair pool 1024
-	(r :: NetRecv ByteString, s) <- newNetChan
-	(r2 :: NetRecv (Auth Int), s2) <- newNetChan
-	authServer print r2 s pub
-	threadDelay 100000
-	f <- authClient r s2 priv
-	f 1
-	f 2
-	f 5

@@ -1,74 +0,0 @@--- | An implementation of communicating sequential processes.
-module Control.CUtils.Processes (CSP(..), runCSP0, runCSP) where
-
-import Control.Concurrent (forkIO)
-import Control.Concurrent.MVar
-import Control.CUtils.FChan
-import Data.List
-import Control.Monad
-import qualified Control.Exception as E
-
-infixr 1 :->
-
--- | The CSP data type:
---
---   :||  - interleave
---
---   :?   - deterministic choice
---
---   Join - interface parallel
---
---   :->  - prefix
---
---   Stop - empty computation
---
---   Do   - execute IO, then behave as the returned process
-data CSP = CSP :|| CSP | CSP :? CSP | Join CSP [String] CSP | String :-> CSP | Stop | Do (IO CSP) deriving Show
-
-instance Show (IO t) where
-	showsPrec _ _ = ("<IO action>"++)
-
-data Side = N | L | R deriving Eq
-
-prefix emitToken chan halt s p = do
-	let may = find (\(int, (_, s2, _):tl) -> s2 == s) (init (zip (inits halt) (tails halt)))
-	case may of
-		Just (int, (status, _, side):tl) -> do
-			side2 <- takeMVar status
-			if side2 == N || side == side2 then do
-					-- Waiting
-					putMVar status side
-					runCSP0 chan (int ++ tl) ((s :-> p) :? ("" :-> Stop))
-				else do
-					-- Wake up
-					putMVar status side2
-					when emitToken (E.catch (fst chan s) (\DoneReadingException -> return ()))
-					runCSP0 chan (int ++ tl) p
-		Nothing -> do
-			when emitToken (E.catch (fst chan s) (\DoneReadingException -> return ()))
-			runCSP0 chan halt p
-
-runCSP0 chan halt (p1 :|| p2) = do
-	forkIO (runCSP0 chan halt p1)
-	runCSP0 chan halt p2
-runCSP0 chan halt ((s1 :-> p1) :? (s2 :-> p2)) = do
-	consumer <- makeConsumer (snd chan)
-	let taking = fst consumer >>= \s -> if s `elem` [s1, s2] then return s else taking
-	s <- taking
-	newChan <- snd consumer
-	prefix False (fst chan, newChan) halt s (if s == s1 then p1 else p2)
-runCSP0 chan halt (Join p1 ls p2) = do
-	statuses <- mapM (const (newMVar N)) ls
-	forkIO (runCSP0 chan (zip3 statuses ls (repeat L) ++ halt) p1)
-	runCSP0 chan (zip3 statuses ls (repeat R) ++ halt) p2
-runCSP0 chan halt (s :-> p) = prefix True chan halt s p
-runCSP0 chan halt Stop = return ()
-runCSP0 chan halt (Do io) = do
-	p <- io
-	runCSP0 chan halt p
-
--- | Run a CSP computation.
-runCSP p = do
-	chan <- newChan
-	runCSP0 chan [] p
-

@@ -2,7 +2,7 @@ 
 import Control.Arrow
 
--- | Arrows possessing a strictness effect
+-- | Arrows that have a strictness effect.
 class Strict a where
 	force :: a t u -> a t u
 

@@ -0,0 +1,51 @@+{-# LANGUAGE GADTs, Trustworthy #-}
+
+-- | Implements rudimentary thread pools.
+module Control.CUtils.ThreadPool (
+-- ** Thread pools
+ThreadPool(..), Interruptible(..),
+-- Pool, createPool,
+NoPool(..), BoxedThreadPool(..)) where
+
+import Control.Concurrent
+import Control.Monad
+import Control.Monad.Loops
+import Data.Word
+import Data.Array.IO
+import Data.IORef
+
+data Pool = Pool
+	!Int
+	!(Chan(IO ()))
+
+-- | Thread pools support some standard operations...
+class ThreadPool pool where
+	addToPool :: pool -> IO () -> IO ()
+
+class Interruptible pool where
+	stopPool :: pool -> IO ()
+
+createPool :: Word32 -> Int -> IO Pool
+createPool channelSize workers = do
+	chn <- newChan
+	stop <- newIORef False
+	let loop = whileM_(return True)$readChan chn>>=id
+	sequence_$replicate workers$forkIO loop -- Start workers
+	return$!Pool workers chn
+
+instance ThreadPool Pool where
+	addToPool (Pool _ channel) m = writeChan channel m
+
+instance Interruptible Pool where
+	stopPool (Pool n channel) = replicateM_ n$writeChan channel$myThreadId>>=killThread
+
+data NoPool = NoPool -- Use if you don't want to use a thread pool.
+
+instance ThreadPool NoPool where
+	addToPool _ = void.forkIO
+
+data BoxedThreadPool where
+	BoxedThreadPool :: (ThreadPool pool) => pool -> BoxedThreadPool
+
+instance ThreadPool BoxedThreadPool where
+	addToPool (BoxedThreadPool pool) = addToPool pool

@@ -1,28 +1,43 @@+{-# LANGUAGE ImplicitParams, Safe #-}
+
 module Data.BellmanFord where
 
-import qualified Data.Map as M
 import Data.Maybe
 import Control.Monad
+import Control.CUtils.DataParallel
+import Control.CUtils.Conc
 import Data.List.Extras.Argmax
+import Data.List
+import Data.Array
 
+keys :: [(a, b)] -> [a]
+keys = map fst
+
+mapWithKey :: (t -> u -> v) -> Array Int (t, u) -> Array Int (t, v)
+mapWithKey f ar = let
+		?seq = True
+		?pool = BoxedThreadPool NoPool in
+	arr_concF(\(_, i)->let (a, b) = ar!i in ((,) $! a) $! f a b) ((), snd(bounds ar)+1)
+
 -- | Edge relaxation.
-relaxEdge nodeWeights edgeWeights x (k, weight) = argmin snd ((k, weight) : map (\y -> (y, maybe (1/0) (\z -> snd (fromJust (M.lookup y nodeWeights)) + z) (M.lookup (y, x) edgeWeights))) (M.keys nodeWeights))
+relaxEdge nodeWeights edgeWeights x (k, weight) = argmin snd ((k, weight) : map (\y -> (y, maybe (1/0) (\z -> snd (fromJust (lookup y nodeWeightsLs)) + z) (lookup (y, x) edgeWeights))) (keys nodeWeightsLs)) where
+	nodeWeightsLs = elems nodeWeights
 
 -- | The Bellman-Ford shortest path algorithm.
-bellmanFord :: (Ord a) => M.Map (a, a) Double -> a -> M.Map a (a, Double)
-bellmanFord gr x = foldl (\weights _ -> M.mapWithKey (relaxEdge weights gr) weights) weights [1..M.size gr+1] where
-	keys = map fst (M.keys gr) ++ map snd (M.keys gr)
-	weights = M.insert x (x, 0) $ M.fromList $ map (\x -> (x, (x, 1/0))) keys
+bellmanFord :: (Eq a) => [((a, a), Double)] -> a -> [(a, (a, Double))]
+bellmanFord gr x = elems$foldl' (\weights _ -> mapWithKey (relaxEdge weights gr) weights) weights [1..length gr+1] where
+	ks = nub (map fst (keys gr) ++ map snd (keys gr))
+	weights = newArray$(x, (x, 0)) : map (\x -> (x, (x, 1/0))) (delete x ks)
 
-retrievePath :: (Ord a) => M.Map a (a, Double) -> a -> a -> [a]
+retrievePath :: (Eq a) => [(a, (a, Double))] -> a -> a -> [a]
 retrievePath mp a a2 | a == a2 = [a]
-retrievePath mp a a2 = retrievePath mp a (fst (fromJust (M.lookup a2 mp))) ++ [a2]
+retrievePath mp a a2 = retrievePath mp a (fst (fromJust (lookup a2 mp))) ++ [a2]
 
 -- | Cycle finding
-cycles :: (Ord a) => M.Map (a, a) () -> a -> Maybe a
+cycles :: (Eq a) => [((a, a), ())] -> a -> Maybe a
 cycles gr x = do
-	(y, z) <- M.lookup x weights
+	(y, z) <- lookup x weights
 	guard (round z < 0)
 	return y where
-	gr' = fmap (const (-1)) gr
-	weights = bellmanFord gr' x
+	gr' = mapWithKey (\_ _ -> -1)$newArray gr
+	weights = bellmanFord(elems gr') x