ConcurrentUtils 0.4.5.0 → 0.5.0.0

raw patch · 14 files changed

+527/−976 lines, 14 filesdep +assertdep +atldep +extradep −MonadRandomdep −arrowsdep −hashabledep ~monad-loopsPVP ok

version bump matches the API change (PVP)

Dependencies added: assert, atl, extra, profunctors, time, vector

Dependencies removed: MonadRandom, arrows, hashable, hashtables, stm, tagged, ttrie

Dependency ranges changed: monad-loops

API changes (from Hackage documentation)

Files

• ConcurrentUtils.cabal +15/−8
• Control/CUtils/AList.hs +0/−81
• Control/CUtils/AssociativeFold.hs +42/−0
• Control/CUtils/BoundedQueue.hs +86/−0
• Control/CUtils/CPUMultiThreading.hs +132/−0
• Control/CUtils/Conc.hs +43/−157
• Control/CUtils/DataParallel.hs +0/−453
• Control/CUtils/Deadlock.hs +0/−195
• Control/CUtils/Dyn.hs +1/−1
• Control/CUtils/FChan.hs +1/−1
• Control/CUtils/Semaphore.hs +39/−0
• Control/CUtils/StrictArrow.hs +50/−7
• Control/CUtils/ThreadPool.hs +118/−30
• Data/BellmanFord.hs +0/−43

@@ -2,13 +2,15 @@ -- documentation, see http://haskell.org/cabal/users-guide/
 
 name:                ConcurrentUtils
-version:             0.4.5.0
+version:             0.5.0.0
 synopsis:            Concurrent utilities
-description: Release notes for version 0.4.5.0:
+description: Release notes for version 0.5.0.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.
+  * Deprecated and removed the 'DataParallel' module, after it performed disappointingly on my own benchmarks, and failed to achieve sufficient parallelism to justify it; deprecated and removed "deadlock" and Data.BellmanFord modules.
   .
-  * Removed most code for Channel library; it now passes through to Chan.
+  * Refactored the Conc module and renamed as CPUMultiThreading; improved the implementation of thread pools. By breaking tasks into smaller chunks when putting them on the thread pools, it avoids occupying the thread pools with long running tasks, hopefully making performance predictable when different tasks contend for the same thread pool.
+  .
+  * Added a handrolled(?TODO) semaphore implementation (semaphore) which uses CAS instructions in the common case to reduce latency
 license:             GPL-2
 license-file:        LICENSE
 author:              James Candy
@@ -16,9 +18,14 @@ -- copyright:           
 category:            Concurrency
 build-type:          Simple
-cabal-version:       >=1.8
+cabal-version:       >=1.18
 
 library
-  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, 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
+  exposed-modules:     Control.CUtils.CPUMultiThreading, Control.CUtils.ThreadPool, Control.CUtils.BoundedQueue, Control.CUtils.AssociativeFold
+   -- legacy modules
+    Control.CUtils.FChan, Control.CUtils.Conc, Control.CUtils.StrictArrow,  Control.CUtils.Dyn, Control.CUtils.Channel
+  other-modules:       Control.CUtils.Split, Control.CUtils.Semaphore
+  default-language:    Haskell2010
+  build-depends:       base >=4.4.0.0 && <=5, containers, monads-tf, atl >= 15322.1, list-extras, extra, strict >= 0.3.2, monad-loops ==0.4.*, time ==1.8.*, vector,  assert, array, parallel, profunctors 
+--, atomic-primops ==0.8.*, primitive ==0.6.*
+

@@ -1,81 +0,0 @@-{-# LANGUAGE Trustworthy, DeriveDataTypeable #-}
-
--- | Lists suitable for parallel execution (taken from Hackage's monad-par package). (For converting to regular lists, there is the toList function in Data.Foldable.)
-module Control.CUtils.AList (AList(..), filterAList, assocFold, monoid, lenAList, findAList, concatAList) where
-
-import Control.Parallel
-import Control.Monad
-import Control.Applicative
-import Data.Monoid
-import Data.Foldable (Foldable, foldMap)
-import Data.Traversable (Traversable, traverse, foldMapDefault)
-import Data.Data
-
-data AList t = Append (AList t) (AList t) | List [t] deriving (Eq, Ord, Show, Typeable, Data)
-
-instance Monad AList where
-	return x = List [x]
-	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 []
-	mplus m n = (m `par` n) `pseq` case (m, n) of
-		(List [x], List xs) -> List (x:xs)
-		(List [x], Append y z) -> Append (mplus m y) z
-		(List [], n) -> n
-		(m, List []) -> m
-		_ -> Append m n
-
-instance Applicative AList where
-	pure = return	
-	(<*>) = ap
-
-instance Alternative AList where
-	empty = mzero
-	(<|>) = mplus
-
-instance Functor AList where
-	fmap f m = m >>= return . f
-
-instance Traversable AList where
-	traverse f (Append ls ls2) = Append <$> traverse f ls <*> traverse f ls2
-	traverse f (List ls) = List <$> traverse f ls
-
-instance Foldable AList where
-	foldMap = foldMapDefault
-
--- | Filters the AList using a predicate.
-filterAList f ls = ls >>= \x -> List $ if f x then [x] else []
-
-noNils (Append m n) = noNils m `mplus` noNils n
-noNils ls = ls
-
-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.
-assocFold f = assocFold0 f . noNils
-
--- | Combine monoid elements to get a result.
-monoid ls = if noNils ls == List [] then
-		mempty
-	else
-		assocFold mappend ls
-
--- | Length of an AList.
-lenAList ls = if noNils ls == List [] then
-		0
-	else
-		assocFold (+) (fmap (const 1) ls)
-
--- | Find the first element satisfying a predicate.
-findAList f = getFirst . monoid . fmap (\x -> First $ if f x then Just x else Nothing)
-
--- | Concatenate an AList of ALists.
-concatAList ls = ls >>= id
-

@@ -0,0 +1,42 @@+{-# LANGUAGE ScopedTypeVariables, FlexibleContexts, Trustworthy #-}
+module Control.CUtils.AssociativeFold (assocFold, assocFold_pattern) where
+import Control.CUtils.CPUMultiThreading
+import Data.List.Extra
+import Data.Array.Unsafe
+import Data.Array.IO
+import Data.Array.Base
+import Data.Array
+import Control.Monad
+import Control.Exception
+import System.IO.Unsafe
+chunkSize::Int
+chunkSize = 10000
+assocFold :: forall t. Pool -> (t->t->IO t) -> Int -> (Int -> t) -> IO t
+-- | Concurrent evaluation of an associative fold. The caller is responsible
+-- for introducing appropriate strictness for the results in the second argument.
+assocFold _ _ n _ | n <= 0 = throwIO$ErrorCall"assocFold: list is empty"
+assocFold _ _ n f2 | n == 1 = return(f2 0)
+assocFold pool f n f2 = do
+	let mx = pred n `div` chunkSize
+	let ls2 =[0.. mx]
+	let l = succ mx
+	-- Using unsafe interleaving with this line seems to help the tasks start faster.
+
+	ar::IOArray Int t <- unsafeInterleaveIO(newArray_(0,mx))
+	let ls3 = fmap(f3 ar) ls2
+	simpleConc_ pool ls3()
+	ar2 :: Array Int t <- unsafeFreeze ar
+	-- Each recursive call reduces the size of the problem by a factor of 'chunkSize'.
+	assocFold pool f l(unsafeAt ar2)
+	where
+	f3 ar ii = do
+		let x:xs= [chunkSize*ii..pred(min n(chunkSize*ii+chunkSize))]
+		let x2 = f2 x
+		x3 <- foldM((.f2).f) x2 xs
+		writeArray ar ii x3
+assocFold_pattern :: Pool -> (t->t->IO t) -> Int -> (Int -> IO t) -> IO t
+-- | Pattern which is a simple wrapper around 'assocFold'.
+assocFold_pattern pool f = (join.).assocFold pool( \x x2 -> do
+	x_res <- x
+	x2_res <- x2
+	return$!f x_res x2_res)

@@ -0,0 +1,86 @@+{-# LANGUAGE FlexibleContexts, TypeFamilies, DeriveDataTypeable, Trustworthy #-}
+module Control.CUtils.BoundedQueue (BoundedQueue, newRB, writeRB, readRB, lengthRB, getSizeRB) where
+--import qualified Control.Concurrent.SSem as S
+import Control.Concurrent.MVar
+import Control.Monad.ST
+import Control.Exception.Assert
+import Control.Monad
+import Control.Exception
+import Data.IORef
+import Data.Vector.Generic.Mutable hiding (MVector)
+import qualified Data.Vector.Generic.Mutable as MV
+import Data.Vector.Mutable (MVector)
+import Data.Data
+import Control.Parallel.Strategies
+import Control.CUtils.Semaphore
+import Prelude hiding (length, read)
+data BoundedQueue t = BoundedQueue { vector_ :: !(MVector RealWorld t),
+	range_mvar_ :: !(MVar(Int,Int)),
+	empty_ssem_ :: !Sem,
+	full_ssem_ :: !Sem }
+	deriving (Typeable)
+-- The strictest possible constraint on these semaphores would be the equation
+-- empty+full = n. This equation is relaxed to the inequality empty+full <= n,
+-- so that producers/consumers may pass through intermediate states where the
+-- total is less than n.
+
+instance (Typeable t) => Data(BoundedQueue t)
+
+newRB :: (MV.MVector MVector t) => Int -> IO(BoundedQueue t)
+newRB n | n<=0 = throwIO$ErrorCall"newRB: require positive size"
+newRB n = liftM4 BoundedQueue
+	(new n)
+	(newMVar$!(0,0)) -- (lowest populated index, number of elements)
+	newSem
+	(newSem>>= \s->putSem s n>>return s)-- start out empty
+
+
+writeRB :: BoundedQueue t -> t -> IO()
+{-# INLINABLE writeRB #-}
+writeRB rb x = mask_$do
+	takeSem(full_ssem_ rb) 1 -- Wait until space becomes free in the buffer.
+--	putStrLn"f"
+	b <- modifyMVar(range_mvar_ rb) f
+
+	putSem(empty_ssem_ rb) 1
+	where
+	f (low,size) = do
+		let nLen= length(vector_ rb)
+		write(vector_ rb) ((low+size)`mod`nLen) x
+		let size' = succ size
+		assert(size'>=0 && size'<=nLen) (return())
+		return$!(((low,size'), size/=nLen)`using`evalTuple2(evalTuple2 r0 rseq) r0)
+
+
+
+readRB :: BoundedQueue t -> IO t
+{-# INLINABLE readRB #-}
+readRB rb = mask_$do
+	takeSem(empty_ssem_ rb) 1
+--	putStrLn"e"
+	(b,x) <- modifyMVar(range_mvar_ rb) f
+	putSem(full_ssem_ rb) 1
+
+
+	return  x
+
+
+	where
+	f (low,size) = do
+		let nLen = length(vector_ rb)
+		x <- read(vector_ rb) low
+		let low' = succ low `mod` nLen
+		let size' = pred size
+		assert(size'>=0 && size'<=nLen) (return())
+		return$!(((low',size'), (size'/=0,x))`using`evalTuple2(evalTuple2 r0 rseq) r0)
+
+lengthRB :: BoundedQueue t -> Int
+{-# INLINE lengthRB #-}
+-- | Read the maximum size of the bounded queue.
+lengthRB = length. vector_
+
+
+getSizeRB :: BoundedQueue t -> IO Int
+{-# INLINE getSizeRB #-}
+-- | Snapshot buffer size.
+getSizeRB = liftM snd. readMVar. range_mvar_

@@ -0,0 +1,132 @@+{-# LANGUAGE Trustworthy, ScopedTypeVariables, ConstraintKinds , DeriveDataTypeable #-}
+-- | A module of concurrent higher order functions.
+module Control.CUtils.CPUMultiThreading (ExceptionList(..), ConcException(..), ConcurrentMethod, ConcurrentMethodAdapter, module Control.CUtils.ThreadPool, simpleConc_, concurrent_, throwToCallerAdapter_, toNewStyle) where
+
+import Control.Exception
+import Control.Concurrent
+
+import Control.Concurrent.Chan
+
+import Data.Typeable
+import Control.Monad.Loops
+
+
+
+
+
+import Data.IORef
+
+
+import Data.List.Extra
+import Data.Maybe
+import Control.Monad
+import Control.Monad.Identity
+import Control.Category
+import Control.Arrow
+import System.IO
+import Control.CUtils.Semaphore
+import Control.CUtils.ThreadPool
+import Prelude hiding (catch, (.), id)
+
+-- | For exceptions caused by caller code.
+data ExceptionList = ExceptionList[SomeException] deriving (Show, Typeable)
+
+instance Exception ExceptionList
+
+-- | For internal errors. If a procedure throws this, some threads it created may still be running.
+-- This exception type is provided out of an abundance of caution, in case you want to
+-- take precautions against the activities of threads that for whatever reason cannot
+-- be terminated. If thrown it is never among the exceptions listed inside an ExceptionList.
+data ConcException = ConcException deriving (Show, Typeable)
+
+instance Exception ConcException
+
+type Over p f t u v w = p v(f w) -> t -> f u
+type Over' p f t u = Over p f t t u u
+
+-- | A type for methods that accept a list of tasks.
+type ConcurrentMethod t t2 = Over(Kleisli((->) Int)) IO () t () t2
+
+-- | A type for functions that transform a base method, taking a thread pool also.
+type ConcurrentMethodAdapter t t2 = Pool -> (Int -> ConcurrentMethod t t2) -> Int -> ConcurrentMethod t t2
+
+simpleConc_ :: (Foldable f)=> Pool -> f(IO()) -> () -> IO()
+-- | Run the collection of tasks in the specified thread pool. Each task does not necessarily
+-- get its own thread--a best effort is made to spread the load over all threads in the
+-- thread pool.
+simpleConc_ ls mnds unit= do
+	sem <- newSem
+	-- The number of tasks successfully spawned is maintained in a reference; in the
+	-- event of an exception this indicates how many tasks to wait for during teardown.
+	ref <- newIORef 0
+	catch
+		(mapM_(\m ->do
+		addToPoolMulti ls(finally m(putSem sem 1))
+		modifyIORef' ref succ)
+		mnds)
+
+		(\(ex :: SomeException) -> do
+
+
+		-- Print the exception immediately so that information on the exception is
+		-- available in case one of the threads went away indefinitely.
+		hPrint stderr ex
+		nLen <- readIORef ref
+		takeSem sem nLen
+		throwIO ex)
+
+	nLen <- readIORef ref
+	takeSem sem nLen
+
+
+chunkSize :: Int
+chunkSize= 10000
+
+concurrent_ ::  Pool -> Int -> ConcurrentMethod() t
+-- | This function implements some policy for 'simpleConc_'. 'simpleConc_' makes the guarantee
+-- that the tasks given as an argument, map one-to-one to the tasks run on the thread pool.
+-- This guarantee is dropped for the function 'concurrent_', which allows more optimization.
+--
+-- In order to get the tasks, the integer argument 'n' is accepted and the functional
+-- 'mnds' is evaluated in the range 0 to n-1 inclusive.
+concurrent_ ls n mnds = simpleConc_ ls
+	(map
+	(\ii -> mapM_(runKleisli mnds()) [ii..pred(min n(ii+chunkSize))])
+	[0,chunkSize..n-1])
+
+
+
+
+
+--------------------------------------------
+-- Exception handling
+
+getExceptions exs = do
+	writeChan exs$!mzero
+	ls <- getChanContents exs
+	let exslst = map fromJust . takeWhile isJust$ls
+
+	when(not(null exslst))$throwIO(ExceptionList exslst)
+
+throwToCallerAdapter_ ::
+	Pool
+	-> (t1 -> ConcurrentMethod() ())
+	-> t1 -> ConcurrentMethod() ()
+-- | An adapter which modifies the argument concurrent method, to implement an exception
+-- handling policy in which exceptions are collected in a list, which is thrown as an
+-- exception in the caller. This appropriates the exception handling behavior of old
+-- versions of this package.
+throwToCallerAdapter_ _ method arg mnds unit = do
+	exs <- newChan
+	_ <- method arg(arr(f exs).mnds) unit
+	getExceptions exs
+
+	where
+	f exs mnd = catch mnd(\(ex::SomeException) -> writeChan exs$!return ex)
+
+------------------------------------------
+-- Optic adapter
+
+toNewStyle :: ((Int -> IO t2) ->IO t) -> ConcurrentMethod t t2
+{-# INLINE toNewStyle #-}
+toNewStyle x x2 unit= x(runKleisli x2 unit)

@@ -1,174 +1,60 @@-{-# LANGUAGE Trustworthy, ScopedTypeVariables, DeriveDataTypeable, ImplicitParams, FlexibleInstances, FlexibleContexts #-}
--- | A module of concurrent higher order functions.
-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
+{-# LANGUAGE NoMonomorphismRestriction, ImplicitParams, FlexibleContexts, Trustworthy #-}
+-- |  Compatibility shims for old version
+module Control.CUtils.Conc (ExceptionList(..), ConcException(..), concF_, conc_, concF, conc, arr_assocFold)  where
+import Data.Array.IO
+import Data.Array (Array)
+import Data.Array.Base
 import Data.Array.Unsafe
-import Data.Array.MArray
-import Data.IORef
-import Control.Monad
 import Control.Arrow
 import System.IO.Unsafe
+import Control.CUtils.CPUMultiThreading
+import Control.CUtils.AssociativeFold
+import Control.CUtils.ThreadPool
 
--- | For exceptions caused by caller code.
-data ExceptionList = ExceptionList [SomeException] deriving (Show, Typeable)
+concF_ :: (?pool :: Pool) => Int -> ConcurrentMethod() ()
+concF_ = let pool = ?pool in throwToCallerAdapter_ pool(concurrent_ pool)
 
-instance Exception ExceptionList
 
--- | For internal errors. If a procedure throws this, some threads it created may still be running. It is thrown separately from ExceptionList.
-data ConcException = ConcException deriving (Show, Typeable)
+{-# INLINE partConc_ #-}
+partConc_ :: (IArray ar e, Ix i, ?pool :: Pool) => ar i e-> Kleisli((->) Int) () (IO()) -> () -> IO()
+partConc_ mnds = concF_(rangeSize(bounds mnds))
 
-instance Exception ConcException
 
-simpleConc_ mnds = do
-	sem <- newQSemN 0
-	mapM_ (\m -> addToPool ?pool (do
-			m
-			signalQSemN sem 1))
-		mnds
-	waitQSemN sem (length mnds)
 
-divideUp nPieces nVals = zip (0 : divisions) divisions where
-	divisions = if nPieces >= nVals then
-			[1..nVals]
-		else
-			map (`div` nPieces) $ take nPieces $ iterate (nVals +) nVals
-
-getExceptions exs = do
-	writeChan exs Nothing
-	exslst <- let chanToList exslst = do
-					may <- readChan exs
-					case may of
-						Just ex -> case fromException ex of
-							Just (_ :: ConcException) -> throwIO ex
-							Nothing -> chanToList (ex : exslst)
-						Nothing -> return exslst in
-			chanToList []
-	unless (null exslst) $ throwIO (ExceptionList exslst)
-
--- | A type class of arrows that support some form of concurrency.
-class Concurrent a where
-	-- | Runs an associative folding function on the given array.
-	--   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 :: (?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, ?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
-	arr_assocFold f g = Kleisli $ \(init, parm) -> do
-		let (lo, hi) = bounds parm
-		when (lo > hi) $ error "Conc.arr_assocFold: empty list"
-		exs <- newChan
-		caps <- getNumCapabilities
-		-- With unlimited caps, you can do sqrt(n) folds on each thread, then sqrt(n) to fold the results (O(sqrt(n)f(n)) time).
-		let effectiveCaps = ceiling (sqrt (fromIntegral (rangeSize (bounds parm)))) `min` caps
-		ar <- (newArray_ (0, effectiveCaps - 1) :: IO (IOArray Int b))
-		let
-			rtnException ex = writeChan exs (Just ex) >> return undefined
-			innerExHandler m = catch m rtnException
-			outerExHandler m = catch m (\(_ :: SomeException) -> rtnException (toException ConcException)) in
-			outerExHandler $ simpleConc_ $ map (\(i, (x, y)) ->
-				innerExHandler $ foldM (\x -> runKleisli f . (,) x . g . (parm !)) init [x..y] >>= writeArray ar i) $ zip [0..] (divideUp effectiveCaps (rangeSize $ bounds parm))
-		getExceptions exs
-		ls <- getElems ar
-		foldM (curry (runKleisli f)) init ls
-	arr_concF_ mnds = Kleisli $ \(parm, n) -> do
-		exs <- newChan
-		caps <- getNumCapabilities
-		let
-			rtnException ex = writeChan exs (Just ex) >> return undefined
-			innerExHandler m = catch m rtnException
-			outerExHandler m = catch m (\(_ :: SomeException) -> rtnException (toException ConcException)) in
-			outerExHandler $
-			simpleConc_ $ map (\(x, y) -> outerExHandler $ (if ?seq then sequence_ else simpleConc_) $ map (innerExHandler . runKleisli mnds . (,) parm) [x..y-1]) $ divideUp caps n
-		getExceptions exs
-	arr_concF mnds = Kleisli $ \(parm, n) -> partConcF (0, n - 1) (concF_ n) (runKleisli mnds . (,) parm)
-	arr_oneOfF mnds = Kleisli $ \(parm, n) -> partOneOfF (0, n - 1) (runKleisli mnds . (,) parm)
-
--- '->' has no effects, but one can compute its results in parallel anyway (pointlessly,
--- in the case of 'arr_concF_').
-instance Concurrent (->) where
-	arr_assocFold f g x = unsafePerformIO $ assocFold (\x y -> return $! f (x, y)) g x
-	arr_concF_ _ = arr (const ())
-	arr_concF mnds (parm, n) = let ?seq = True in unsafePerformIO $ concF n ((return $!) . mnds . (,) parm)
-	arr_oneOfF mnds (parm, n) = unsafePerformIO $ oneOfF n ((return $!) . mnds . (,) parm)
-
--- |
-assocFold f g = runKleisli (arr_assocFold (Kleisli (uncurry f)) g)
-
-partConc_ f mnds = concF_ (rangeSize (bounds mnds)) $ f . (+ fst (bounds mnds))
-
--- |
-concF_ n mnds = runKleisli (arr_concF_ (Kleisli (mnds . snd))) ((), n)
-
--- |
-concF n mnds = runKleisli (arr_concF (Kleisli (mnds . snd))) ((), n)
-
--- |
-conc_ mnds = partConc_ (mnds !) mnds
+conc_ :: (IArray ar(IO()), Ix i, ?pool :: Pool) => 
+	ar i(IO()) -> IO()
+conc_ mnds = partConc_ mnds(Kleisli(const$ unsafeAt mnds)) ()
 
-unsafeFreeze' :: IOArray Int e -> IO (Array Int e)
+unsafeFreeze' :: (Ix i) => IOArray i e -> IO(Array i e)
 unsafeFreeze' = unsafeFreeze
 
-partConcF bnds f mnds = do
-	res <- newArray_ bnds
-	f (\i -> do
-		x <- mnds i
-		writeArray res i x)
+{-# INLINE partConcF #-}
+partConcF :: (Ix i) => (i,i) -> ConcurrentMethod() () -> ConcurrentMethod(Array i e ) e
+partConcF bnds f mnds unit = do
+	res <- unsafeInterleaveIO(newArray_ bnds)
+	_ <- f(Kleisli$ const$ \i -> do
+		x <- runKleisli mnds unit i
+		unsafeWrite res i x)
+		unit
 	unsafeFreeze' res
 
--- | The next function takes an implicit parameter ?seq. Set it to True
--- if you want to only spawn threads for the capabilities (same as /assocFold/;
--- good for speed). If you need all the actions to be executed concurrently,
--- set it to False.
-
--- Runs several computations concurrently, and returns their results as an array. Waits for all threads to end before returning.
-conc mnds = partConcF (bounds mnds) (\f -> partConc_ f mnds) (mnds !)
-
--- | Version of concF specialized for two computations.
-concP m m2 = let ?seq = False in liftM ((\[Left x, Right y] -> (x, y)) . elems)
-	$ concF 2 (\i -> if i == 0 then
-			liftM Left m
-		else
-			liftM Right m2)
-
-progressConcF n f = do
-	res <- concF n (\i -> f i >>= \x -> when (i * 80 `mod` n == 0) (putChar '|') >> return x)
-	putStrLn ""
-	return res
-
-partOneOfF bnds mnds = do
-	thds <- newIORef []
-	chn <- newChan
-	finally (do
-		mapM_ (\n -> do
-			thd <- forkIO (catch (mnds n >>= writeChan chn . Right) (\(ex :: SomeException) -> writeChan chn (Left ex) >> return undefined))
-			modifyIORef thds (thd:))
-			(range bnds)
-		let chanToList n exs = if n == rangeSize bnds then
-				throwIO (ExceptionList exs)
-			else readChan chn >>=
-				either
-					(chanToList (n + 1) . (:exs))
-					return in
-			chanToList 0 [])
-		(catch (readIORef thds >>= mapM_ killThread) (\(_ :: SomeException) -> throwIO ConcException))
+concF :: (?pool :: Pool) => Int -> ConcurrentMethod(Array Int t) t
+concF n = partConcF(0,n-1) (concF_ n)
 
-oneOfF n mnds = runKleisli (arr_oneOfF (Kleisli (mnds . snd))) ((), n)
+-- | Runs several computations concurrently, and returns their results as an array. Waits for all threads to end before returning.
+conc :: (IArray ar(IO e), Ix i, ?pool :: Pool) =>
+	ar i(IO e) -> IO(Array i e)
+conc mnds = partConcF(bounds mnds) (partConc_ mnds) (Kleisli$const$ unsafeAt mnds) ()
 
--- | Runs several computations in parallel, and returns one of their results (terminating the other computations).
-oneOf :: Array Int (IO a) -> IO a
-oneOf mnds = partOneOfF (bounds mnds) (mnds !)
+arr_assocFold :: (IArray ar t, Ix i, ?pool :: Pool) => Kleisli IO(u,u) u ->
+	(t -> u) ->
+	Kleisli IO(t,ar i t) u
+arr_assocFold f g= Kleisli$ \ (_,ar) ->
+	let pool = ?pool in
+	assocFold pool(curry(runKleisli f)) (rangeSize(bounds ar)) (g.unsafeAt ar)
 
+{-# SPECIALIZE conc_ :: (?pool :: Pool) => Array Int(IO()) -> IO() #-}
+{-# SPECIALIZE conc :: (?pool :: Pool) => Array Int(IO e) -> IO(Array Int e) #-}
+{-# SPECIALIZE arr_assocFold :: (?pool :: Pool) =>  Kleisli IO(u,u) u ->
+	(t -> u) ->
+	Kleisli IO(t,Array Int t) u #-}

@@ -1,453 +0,0 @@-{-# 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,195 +0,0 @@-{-# LANGUAGE Trustworthy, GADTs, ParallelListComp, Arrows, ImplicitParams, ScopedTypeVariables, FlexibleInstances #-}
-
--- | Automatic deadlock avoidance.
-module Control.CUtils.Deadlock (AbstractLock(..), BoxedAbstractLock(..), LockSafetyException(LockTakenTwice, LockNotDeclared), acquire, release, test) where
-
-import Control.Monad
-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.Maybe
-import Data.Function (on)
-import Data.Typeable
-import Data.BellmanFord
-import Data.Hashable
-import qualified Data.HashTable.IO as H
-import System.IO.Unsafe
-import Unsafe.Coerce
-import Control.CUtils.Conc
-import Control.Exception
-import GHC.Conc
-
-class AbstractLock l where
-	lock :: l -> IO ()
-	unlock :: l -> IO ()
-
-instance AbstractLock (MVar ()) where
-	lock m = takeMVar m
-	unlock m = void (tryPutMVar m ())
-
--- | 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.
-
-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
-
-data BoxedAbstractLock where
-	BoxedAbstractLock :: (AbstractLock l, Eq l, Hashable l, Typeable l) => l -> BoxedAbstractLock
-
-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 :: MS.Map BoxedAbstractLock [(ThreadId,[BoxedAbstractLock])]
-{-# NOINLINE resource #-}
-resource = unsafePerformIO$atomically MS.empty
-
-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 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
-
-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 [] = [(x, y)]
-
-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.
-	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 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.
-		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
-	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
-
--- 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)
-
--- | 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

@@ -1,4 +1,4 @@-{-# LANGUAGE Safe, ExistentialQuantification #-}
+{-# LANGUAGE Safe, ExistentialQuantification, DeriveDataTypeable #-}
 
 module Control.CUtils.Dyn (Dyn, value, makeDyn, determineType) where
 

@@ -55,7 +55,7 @@ 	putMVar vr2 chn
 	return (addChan vr2, chn)
 
--- | 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.
+-- | 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 the reads made using the first thunk.
 makeConsumer chn = do
 	vr2 <- newMVar chn
 	return (modifyMVar vr2 (\chn -> do

@@ -0,0 +1,39 @@+{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable #-}
+-- | Shim permitting the insertion of new semaphore implementation(s).
+module Control.CUtils.Semaphore (Sem, newSem, putSem, takeSem) where
+--import Data.Atomics
+--import Data.Primitive.ByteArray
+import Data.Data
+import Data.IORef
+import Foreign.Storable
+import Control.Concurrent.MVar
+import Control.Concurrent
+import Control.Monad.ST
+import Control.Monad
+import Control.Monad.Loops
+import Control.Exception
+import Control.Exception.Assert
+import Control.Concurrent.QSemN
+newtype Sem = Sem { unSem :: QSemN }
+	deriving Typeable
+instance Data Sem
+-- Temp. harness
+newSem :: IO Sem
+-- | Make a new quantity semaphore initialized at zero.
+newSem = liftM Sem(newQSemN 0)
+
+{-getQuantity_ :: Sem -> IO Int
+-- | Snapshot the quantity in the semaphore at a point in time.
+{-# INLINE getQuantity_ #-}
+getQuantity_ s = fetchAddIntArray(marray_ s) 0 0 -- Yes.-}
+
+putSem :: Sem -> Int -> IO()
+{-# INLINE putSem #-}
+-- | Put quantity into the semaphore. Caller is responsible for ensuring that n is non-negative and that it
+-- leaves the counter within the positive integers.
+putSem = signalQSemN. unSem
+
+takeSem :: Sem -> Int -> IO()
+-- |  Probe the semaphore. Quantity requested must be non-negative.
+{-# INLINE takeSem #-}
+takeSem = waitQSemN. unSem

@@ -1,14 +1,57 @@ module Control.CUtils.StrictArrow where
-
 import Control.Arrow
+import Control.Arrow.Reader
+import Control.Arrow.State
+import Control.Arrow.Writer
+import Control.Arrow.Abort
+import Control.Arrow.Transformer
 
+import Control.Category
+import Prelude hiding ((.), id)
+
+type ProfunctorOptic a t u v w = a v w -> a t u
+
+forceDef :: (ArrowApply a) => ProfunctorOptic a t u t u
+{-# INLINE forceDef #-}
+forceDef a = app.arr((,) a $!)
+
 -- | Arrows that have a strictness effect.
-class Strict a where
-	force :: a t u -> a t u
+class (Arrow a) =>Strict a where
+	-- | Laws:
+	--
+	-- * Either 'a' has arrow apply-constraint, or it is an application of an arrow transformer
+	--  or both.
+	--
+	-- * Provided 'a' has arrow apply-constraint, force = 'forceDef'.
+	-- 
+	-- * Provided 'a' is an application of an arrow transformer, 'tmap' force is more defined
+	-- (less strict) than force.
+	--
+	-- * 'force' has the unique most strict implementation which is compatible with the 
+	--  previous laws.
+	--
+	-- These laws place limitations on the effects that 'force'
+	-- can introduce. Reynolds' parametricity also implies that 'force'
+	-- does not change the argument and return values.
+	force :: ProfunctorOptic a t u t u
 
-instance Strict (->) where
-	force f x = x `seq` f x
 
-instance (Monad m) => Strict (Kleisli m) where
-	force a = Kleisli (\x -> x `seq` runKleisli a x)
 
+evalInFst :: (t,u) -> (t,u)
+{-# INLINE evalInFst #-}
+evalInFst pair@(x,_) = x`seq` pair
+
+instance Strict(->) where
+	force = forceDef
+instance (Monad f) => Strict(Kleisli f) where
+	force = forceDef
+--instance (Comonad f) => Strict(CoKleisli f) where
+--	force = forceDef
+instance (Strict a) => Strict(ReaderT r a) where
+	force (ReaderT a) = ReaderT(force a.arr evalInFst)
+instance (Strict a) => Strict(StateT s a) where
+	force (StateT a) = StateT(force a. arr evalInFst)
+instance (Strict a, Monoid w) => Strict(WriterT w a) where
+	force = tmap force
+instance (Strict a, ArrowChoice a) => Strict(AbortT r a) where
+	force = tmap force

@@ -1,51 +1,139 @@-{-# LANGUAGE GADTs, Trustworthy #-}
-
--- | Implements rudimentary thread pools.
-module Control.CUtils.ThreadPool (
--- ** Thread pools
-ThreadPool(..), Interruptible(..),
--- Pool, createPool,
-NoPool(..), BoxedThreadPool(..)) where
+{-# LANGUAGE  LambdaCase, ScopedTypeVariables, GADTs, DeriveDataTypeable, Trustworthy #-}
+module Control.CUtils.ThreadPool (Pool, addToPoolMulti, newPool, stopPool_,
+-- ** Global thread pools
+globalPool,
+-- ** Compatibility shims
+ThreadPool(..), Interruptible(..), NoPool(..), BoxedThreadPool(..)) where
 
+import Control.Exception
 import Control.Concurrent
+
+
+
+import Data.Data
+import Data.Array
+import Data.Foldable
+import Data.IORef
+
+
+
+import Data.List.Extras.Argmax
+import Data.Maybe
 import Control.Monad
+import Control.Monad.Identity
 import Control.Monad.Loops
-import Data.Word
-import Data.Array.IO
-import Data.IORef
+--import Control.Monad.Random
+import Control.CUtils.BoundedQueue
+import System.IO.Unsafe
+import System.IO
+import Prelude hiding (mapM_)
+data Instruction = NextTask(IO()) | S deriving (Typeable)
 
-data Pool = Pool
-	!Int
-	!(Chan(IO ()))
+data Worker= Worker{ instructions :: !(BoundedQueue Instruction), counter :: !(IORef Int) }
+	deriving (Typeable)
 
--- | Thread pools support some standard operations...
+instance Data Instruction
+instance Data Worker
+
+newtype Pool = Pool { workers_ :: Array Int Worker } deriving (Typeable, Data)
+
+addToWorker :: Worker -> IO t -> IO()
+{-# INLINE addToWorker #-}
+addToWorker mv mnd = mask_$ do
+	atomicModifyIORef'(counter mv) (flip(,) ().succ)
+	writeRB(instructions mv) $!NextTask(void mnd)
+
+addToPoolMulti :: Pool -> IO t -> IO()
+{-# INLINABLE addToPoolMulti #-}
+addToPoolMulti (Pool ls) _ | rangeSize(bounds ls)<=0 = throwIO$ErrorCall"addToPoolMulti: pool is empty"
+addToPoolMulti (Pool ls) mnd = do
+	let ls' = toList ls
+	ls2 <- mapM(readIORef.counter) ls'--tbd
+	let worker = fst.argmin snd.zip ls'$ls2
+	addToWorker worker mnd
+
+-- It's desirable for performance to have each worker thread occupied
+-- as often as possible with work. The simplest way of achieving this
+-- is to have a single work queue and have the various threads take
+-- work off it greedily (or do a workstealing approach)
+-- , but this introduces a central point of contention.
+-- An observation: pretty good load balancing can be achieved with an
+-- imprecise estimate of which threads are occupied; then in principle
+-- the source of contention is eliminated; the caller of 'addToPoolMulti'
+-- selects the worker thread to which to assign the work. (The estimate
+-- is imprecise because the code is reading it with limited synchronization,
+-- so the estimate is sometimes out of date.)
+
+newWorker :: IO Worker
+newWorker = do
+	rb <- newRB 10000
+	ref <- newIORef 0
+	let worker = Worker rb ref
+
+	_ <- forkIO(loop worker)
+	return$!worker
+	where
+
+	-- Task  processing loop
+	loop worker = whileM_(readRB(instructions worker) >>= \ case
+		NextTask mnd -> do
+			-- For every task taken off  the work queue, decrement the counter.
+			atomicModifyIORef'(counter worker) (flip(,) ().pred)
+			-- The default exception handling policy for worker threads is to
+			-- print the exception to stderr.
+			catch mnd(\(ex::SomeException) -> hPrint stderr ex)
+			return$!True
+		S -> return$!False) -- Serve a request to terminate the thread pool
+		$return()
+
+newPool :: Int -> IO Pool
+newPool n= liftM(Pool. listArray(0,n-1)) (replicateM  n newWorker)
+
+stopWorker :: Worker -> IO()
+
+stopWorker mv = writeRB(instructions mv)$!S
+
+stopPool_ :: Pool -> IO()
+-- | Stop each worker thread in turn by sending it a message.
+stopPool_ = mapM_ stopWorker.workers_
+
+--------------------------------------------
+-- Global thread pools
+
+globalPool :: Pool
+{-# NOINLINE globalPool #-}
+-- 'Pool' type is abstract, ensuring that the implementation can choose the number of workers
+-- in the pool based on various considerations without breaking referential transparency.
+globalPool = unsafePerformIO(getNumCapabilities >>= newPool)
+
+--------------------------------------------
+-- Compatibility shims
+
+-- | Thread pools support some standard operations....
 class ThreadPool pool where
-	addToPool :: pool -> IO () -> IO ()
+	addToPool :: pool -> IO t -> 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
+	stopPool :: pool -> IO()
 
 instance ThreadPool Pool where
-	addToPool (Pool _ channel) m = writeChan channel m
+	addToPool = addToPoolMulti
 
 instance Interruptible Pool where
-	stopPool (Pool n channel) = replicateM_ n$writeChan channel$myThreadId>>=killThread
+	stopPool = stopPool_
 
-data NoPool = NoPool -- Use if you don't want to use a thread pool.
+-- | Use if you don't want to use a thread pool. The implementation of 'addToPool' spawns a green thread.
+data NoPool = NoPool deriving (Typeable, Data)
 
 instance ThreadPool NoPool where
-	addToPool _ = void.forkIO
+	addToPool _ = void.forkIO.void
 
 data BoxedThreadPool where
 	BoxedThreadPool :: (ThreadPool pool) => pool -> BoxedThreadPool
 
 instance ThreadPool BoxedThreadPool where
-	addToPool (BoxedThreadPool pool) = addToPool pool
+	addToPool(BoxedThreadPool pool) = addToPool pool
+
+{-# SPECIALIZE addToPool :: Pool -> IO t -> IO() #-}
+{-# SPECIALIZE addToPool :: NoPool -> IO t -> IO() #-}
+{-# SPECIALIZE addToPool :: BoxedThreadPool -> IO t -> IO() #-}

@@ -1,43 +0,0 @@-{-# LANGUAGE ImplicitParams, Safe #-}
-
-module Data.BellmanFord where
-
-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 (lookup y nodeWeightsLs)) + z) (lookup (y, x) edgeWeights))) (keys nodeWeightsLs)) where
-	nodeWeightsLs = elems nodeWeights
-
--- | The Bellman-Ford shortest path algorithm.
-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 :: (Eq a) => [(a, (a, Double))] -> a -> a -> [a]
-retrievePath mp a a2 | a == a2 = [a]
-retrievePath mp a a2 = retrievePath mp a (fst (fromJust (lookup a2 mp))) ++ [a2]
-
--- | Cycle finding
-cycles :: (Eq a) => [((a, a), ())] -> a -> Maybe a
-cycles gr x = do
-	(y, z) <- lookup x weights
-	guard (round z < 0)
-	return y where
-	gr' = mapWithKey (\_ _ -> -1)$newArray gr
-	weights = bellmanFord(elems gr') x