diff --git a/Control/LVish.hs b/Control/LVish.hs --- a/Control/LVish.hs +++ b/Control/LVish.hs @@ -1,18 +1,3 @@ -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE DataKinds #-} -- For 'Determinism' --- {-# LANGUAGE ConstraintKinds, KindSignatures #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE BangPatterns #-} -{-# OPTIONS_GHC -fwarn-incomplete-patterns #-} - {-| The @lvish@ package provides a parallel programming model based on monotonically @@ -44,6 +29,13 @@ -} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE CPP #-} + +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + -- This module reexports the default LVish scheduler, adding some type-level -- wrappers to ensure propert treatment of determinism. module Control.LVish @@ -73,205 +65,85 @@ fork, yield, runPar, runParIO, --- runParIO_, runParLogged, --- quiesceAll, - - -- * Various loop constructs - parForL, parForSimple, parForTree, parForTiled, for_, - - -- * Synchronizing with handler pools - L.HandlerPool(), - newPool, - withNewPool, withNewPool_, - quiesce, - - forkHP, - - -- * Debug facilities and internal bits - logStrLn, runParLogged, - LVar() - ) where + -- runParIO_, runParLogged, + -- quiesceAll, -import qualified Data.Foldable as F -import Control.Exception (Exception) -import Control.LVish.Internal -import Control.LVish.DeepFrz.Internal (Frzn, Trvrsbl) -import qualified Control.LVish.SchedIdempotent as L -import Control.LVish.Types -import System.IO.Unsafe (unsafePerformIO, unsafeDupablePerformIO) + -- * Various loop constructs + parForL, parForSimple, parForTree, parForTiled, for_, -import Prelude hiding (rem) --- import GHC.Exts (Constraint) +-- This is not fully ready yet till LVish 2.0: +#ifdef GENERIC_PAR + asyncForEachHP, +#endif --------------------------------------------------------------------------------- + -- * Logical control flow operators + module Control.LVish.Logical, + -- asyncAnd, asyncOr, andMap, orMap, --------------------------------------------------------------------------------- --- Inline *everything*, because these are just wrappers: -{-# INLINE liftQD #-} -{-# INLINE yield #-} -{-# INLINE newPool #-} -{-# INLINE runParIO #-} -{-# INLINE runPar #-} ---{-# INLINE runParThenFreeze #-} -{-# INLINE fork #-} -{-# INLINE quiesce #-} --------------------------------------------------------------------------------- + -- * Synchronizing with handler pools + L.HandlerPool(), + newPool, + withNewPool, withNewPool_, + quiesce, --- | It is always safe to lift a deterministic computation to a --- quasi-deterministic one. -liftQD :: Par Det s a -> Par QuasiDet s a -liftQD (WrapPar p) = (WrapPar p) + forkHP, --- | Cooperatively schedule other threads. -yield :: Par d s () -yield = WrapPar L.yield + -- * Reexport IVar operations for a full, standard "Par Monad" API + module Data.LVar.IVar, --- | Block until a handler pool is quiescent, i.e., until all --- associated parallel computations have completed. -quiesce :: L.HandlerPool -> Par d s () -quiesce = WrapPar . L.quiesce + -- * Debug facilities and internal bits + logDbgLn, runParLogged, runParDetailed, + OutDest(..), DbgCfg (..), + LVar() + ) where --- | A global barrier. Wait for all unblocked, active threads of work in the system --- to complete, and then proceed after that point. -quiesceAll :: Par d s () -quiesceAll = WrapPar L.quiesceAll +-- NOTE : This is an aggregation module: +import Control.LVish.Types +import Control.LVish.Internal as I +import Control.LVish.Basics as B +import Control.LVish.Logical +import qualified Control.LVish.SchedIdempotent as L +import Control.LVish.SchedIdempotentInternal (State) --- | Execute a computation in parallel. -fork :: Par d s () -> Par d s () -fork (WrapPar f) = WrapPar$ L.fork f +import Control.LVish.Logging (OutDest(..)) +import Data.LVar.IVar --- | A version of `fork` that also allows the forked computation to be tracked in a --- `HandlerPool`, that enables the programmer to synchronize on the completion of the --- child computation. But be careful; this does not automatically wait for --- all downstream forked computations (transitively). -forkHP :: Maybe L.HandlerPool -> Par d s () -> Par d s () -forkHP mh (WrapPar f) = WrapPar$ L.forkHP mh f +import Data.IORef +-------------------------------------------------------------------------------- --- | Create a new pool that can be used to synchronize on the completion of all --- parallel computations associated with the pool. -newPool :: Par d s L.HandlerPool -newPool = WrapPar L.newPool +#ifdef GENERIC_PAR +import qualified Control.Par.Class as PC +import qualified Control.Par.Class.Unsafe as PU --- | Execute a Par computation in the context of a fresh handler pool. -withNewPool :: (L.HandlerPool -> Par d s a) -> Par d s (a, L.HandlerPool) -withNewPool f = WrapPar $ L.withNewPool $ unWrapPar . f +instance PC.ParQuasi (Par d s) (Par QuasiDet s) where + -- WARNING: this will no longer be safe when FULL nondetermiism is possible: + toQPar act = unsafeConvert act + +instance PC.ParSealed (Par d s) where + type GetSession (Par d s) = s + +instance PC.LVarSched (Par d s) where + type LVar (Par d s) = L.LVar --- | Execute a Par computation in the context of a fresh handler pool, while --- ignoring the result of the computation. -withNewPool_ :: (L.HandlerPool -> Par d s ()) -> Par d s L.HandlerPool -withNewPool_ f = WrapPar $ L.withNewPool_ $ unWrapPar . f + forkLV = fork + newLV = WrapPar . L.newLV + getLV lv glob delt = WrapPar $ L.getLV lv glob delt + putLV lv putter = WrapPar $ L.putLV lv putter --- | If the input computation is quasi-deterministic (`QuasiDet`), then this may --- throw a `LVishException` nondeterministically on the thread that calls it, but if --- it returns without exception then it always returns the same answer. --- --- If the input computation is deterministic (`Det`), then @runParIO@ will return the --- same result as `runPar`. However, `runParIO` is still possibly useful for --- avoiding an extra `unsafePerformIO` required inside the implementation of --- `runPar`. --- --- In the future, /full/ nondeterminism may be allowed as a third setting beyond --- `Det` and `QuasiDet`. -runParIO :: (forall s . Par d s a) -> IO a -runParIO (WrapPar p) = L.runParIO p + stateLV (L.LVar{L.state=s}) = (PC.Proxy,s) --- | Useful ONLY for timing. -runParIO_ :: (Par d s a) -> IO () -runParIO_ (WrapPar p) = L.runParIO p >> return () + returnToSched = WrapPar $ mkPar $ \_k -> L.sched --- | Useful for debugging. Returns debugging logs, in realtime order, in addition to --- the final result. -runParLogged :: (forall s . Par d s a) -> IO ([String],a) -runParLogged (WrapPar p) = L.runParLogged p +instance PC.LVarSchedQ (Par d s) (Par QuasiDet s) where +-- freezeLV = WrapPar . L.freezeLV -- FINISHME --- | If a computation is guaranteed-deterministic, then `Par` becomes a dischargeable --- effect. This function will create new worker threads and do the work in parallel, --- returning the final result. --- --- (For now there is no sharing of workers with repeated invocations; so --- keep in mind that @runPar@ is an expensive operation. [2013.09.27]) -runPar :: (forall s . Par Det s a) -> a -runPar (WrapPar p) = L.runPar p +instance PU.ParThreadSafe (Par d s) where + unsafeParIO = I.liftIO --- | This is only used when compiled in debugging mode. It atomically adds a string --- onto an in-memory log. -logStrLn :: String -> Par d s () -#ifdef DEBUG_LVAR -logStrLn = WrapPar . L.logStrLn -#else -logStrLn _ = return () -{-# INLINE logStrLn #-} #endif - - --------------------------------------------------------------------------------- --- Extras --------------------------------------------------------------------------------- - -{-# INLINE parForL #-} --- | Left-biased parallel for loop. As worker threads beyond the first are added, --- this hews closer to the sequential iteration order than an unbiased parallel loop. --- --- Takes a range as inclusive-start, exclusive-end. -parForL :: (Int,Int) -> (Int -> Par d s ()) -> Par d s () -parForL (start,end) _ | start > end = error$"parForL: start is greater than end: "++show (start,end) -parForL (start,end) body = do - -- logStrLn$ " initial iters: "++show (end-start) - loop 0 (end - start) 1 - where - loop offset remain chunk - | remain <= 0 = return () - | remain <= chunk = parForSimple (offset, offset+remain) body - | otherwise = do - let nxtstrt = offset+chunk - -- logStrLn$ "loop: .. "++show (offset, remain, chunk) - fork$ parForSimple (offset, nxtstrt) body - loop nxtstrt (remain-chunk) (2*chunk) - -{-# INLINE parForSimple #-} --- | The least-sophisticated form of parallel loop. Fork iterations one at a time. -parForSimple :: (Int,Int) -> (Int -> Par d s ()) -> Par d s () -parForSimple range fn = do - for_ range $ \i -> fork (fn i) - --- | Divide the iteration space recursively, but ultimately run every iteration in --- parallel. That is, the loop body is permitted to block on other iterations. -parForTree :: (Int,Int) -> (Int -> Par d s ()) -> Par d s () -parForTree (start,end) _ - | start > end = error$"parForTree: start is greater than end: "++show (start,end) -parForTree (start,end) body = do - loop 0 (end - start) - where - loop offset remain - | remain == 1 = body offset - | otherwise = do - let (half,rem) = remain `quotRem` 2 - fork$ loop offset half - loop (offset+half) (half+rem) - - --- | Split the work into a number of tiles, and fork it in a tree topology. -parForTiled :: Int -> (Int,Int) -> (Int -> Par d s ()) -> Par d s () -parForTiled otiles (start,end) body = do - loop 0 (end - start) otiles - where - loop offset remain tiles - | remain == 1 = body offset - | tiles == 1 = for_ (offset,offset+remain) body - | otherwise = do - let (half,rem) = remain `quotRem` 2 - (halfT,remT) = tiles `quotRem` 2 - fork$ loop offset half halfT - loop (offset+half) (half+rem) (halfT+remT) - - --- | A simple for loop for numeric ranges (not requiring deforestation --- optimizations like `forM`). Inclusive start, exclusive end. -{-# INLINE for_ #-} -for_ :: Monad m => (Int, Int) -> (Int -> m ()) -> m () -for_ (start, end) _fn | start > end = error "for_: start is greater than end" -for_ (start, end) fn = loop start - where - loop !i | i == end = return () - | otherwise = do fn i; loop (i+1) +------ DUPLICATED: ----- +mkPar :: ((a -> L.ClosedPar) -> SchedState -> IO ()) -> L.Par a +mkPar f = L.Par $ \k -> L.ClosedPar $ \q -> f k q +type SchedState = State L.ClosedPar LVarID +type LVarID = IORef () diff --git a/Control/LVish/Basics.hs b/Control/LVish/Basics.hs new file mode 100644 --- /dev/null +++ b/Control/LVish/Basics.hs @@ -0,0 +1,267 @@ + {-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE DataKinds #-} -- For 'Determinism' +-- {-# LANGUAGE ConstraintKinds, KindSignatures #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE BangPatterns #-} +{-# OPTIONS_GHC -fwarn-incomplete-patterns #-} + +-- | An internal module simply reexported by Control.LVish. + +module Control.LVish.Basics + ( Par(), LVar(), + Determinism(..), liftQD, + LVishException(..), L.HandlerPool(), + fork, yield, + runPar, runParIO, runParLogged, runParDetailed, + newPool, withNewPool, withNewPool_, + quiesce, forkHP, logDbgLn, + + parForL, parForSimple, parForTree, parForTiled, for_ + +#ifdef GENERIC_PAR + , asyncForEachHP +#endif + ) + where + +import Control.Monad (forM_) +import qualified Data.Foldable as F +import Control.Exception (Exception, SomeException) +import Control.LVish.Internal as I +import Control.LVish.DeepFrz.Internal (Frzn, Trvrsbl) +import qualified Control.LVish.SchedIdempotent as L +import qualified Control.LVish.Logging as Lg +import Control.LVish.Types +import System.IO.Unsafe (unsafePerformIO, unsafeDupablePerformIO) +import Prelude hiding (rem) + +#ifdef GENERIC_PAR +import qualified Control.Par.Class.Unsafe as PU +import qualified Control.Par.Class as PC +import qualified Data.Splittable.Class as SC + +instance PU.ParMonad (Par d s) where + fork = fork + internalLiftIO = I.liftIO +#endif + +{-# DEPRECATED parForL, parForSimple, parForTree, parForTiled + "These will be removed in a future release in favor of a more general approach to loops." #-} + +-------------------------------------------------------------------------------- + +-------------------------------------------------------------------------------- +-- Inline *everything*, because these are just wrappers: +{-# INLINE liftQD #-} +{-# INLINE yield #-} +{-# INLINE newPool #-} +{-# INLINE runParIO #-} +{-# INLINE runPar #-} +--{-# INLINE runParThenFreeze #-} +{-# INLINE fork #-} +{-# INLINE quiesce #-} +-------------------------------------------------------------------------------- + +-- | It is always safe to lift a deterministic computation to a +-- quasi-deterministic one. +liftQD :: Par Det s a -> Par QuasiDet s a +liftQD (WrapPar p) = (WrapPar p) + +-- | Cooperatively schedule other threads. +yield :: Par d s () +yield = WrapPar L.yield + +-- | Block until a handler pool is quiescent, i.e., until all +-- associated parallel computations have completed. +quiesce :: L.HandlerPool -> Par d s () +quiesce = WrapPar . L.quiesce + +-- | A global barrier. Wait for all unblocked, active threads of work in the system +-- to complete, and then proceed after that point. +quiesceAll :: Par d s () +quiesceAll = WrapPar L.quiesceAll + +-- | Execute a computation in parallel. +fork :: Par d s () -> Par d s () +fork (WrapPar f) = WrapPar$ L.fork f + +-- | A version of `fork` that also allows the forked computation to be tracked in a +-- `HandlerPool`, that enables the programmer to synchronize on the completion of the +-- child computation. But be careful; this does not automatically wait for +-- all downstream forked computations (transitively). +forkHP :: Maybe L.HandlerPool -> Par d s () -> Par d s () +forkHP mh (WrapPar f) = WrapPar$ L.forkHP mh f + +-- | Create a new pool that can be used to synchronize on the completion of all +-- parallel computations associated with the pool. +newPool :: Par d s L.HandlerPool +newPool = WrapPar L.newPool + +-- | Execute a Par computation in the context of a fresh handler pool. +withNewPool :: (L.HandlerPool -> Par d s a) -> Par d s (a, L.HandlerPool) +withNewPool f = WrapPar $ L.withNewPool $ unWrapPar . f + +-- | Execute a Par computation in the context of a fresh handler pool, while +-- ignoring the result of the computation. +withNewPool_ :: (L.HandlerPool -> Par d s ()) -> Par d s L.HandlerPool +withNewPool_ f = WrapPar $ L.withNewPool_ $ unWrapPar . f + +-- | If the input computation is quasi-deterministic (`QuasiDet`), then this may +-- throw a `LVishException` nondeterministically on the thread that calls it, but if +-- it returns without exception then it always returns the same answer. +-- +-- If the input computation is deterministic (`Det`), then @runParIO@ will return the +-- same result as `runPar`. However, `runParIO` is still possibly useful for +-- avoiding an extra `unsafePerformIO` required inside the implementation of +-- `runPar`. +-- +-- In the future, /full/ nondeterminism may be allowed as a third setting beyond +-- `Det` and `QuasiDet`. +runParIO :: (forall s . Par d s a) -> IO a +runParIO (WrapPar p) = L.runParIO p + +-- | Useful ONLY for timing. +runParIO_ :: (Par d s a) -> IO () +runParIO_ (WrapPar p) = L.runParIO p >> return () + +-- | Useful for debugging. Returns debugging logs, in realtime order, in addition to +-- the final result. +runParLogged :: (forall s . Par d s a) -> IO ([String],a) +runParLogged (WrapPar p) = L.runParLogged p + +-- | A variant with full control over the relevant knobs. +-- +-- Returns a list of flushed debug messages at the end (if in-memory logging was +-- enabled, otherwise the list is empty). +-- +-- This version of runPar catches ALL exceptions that occur within the runPar, and +-- returns them via an Either. The reason for this is that even if an error +-- occurs, it is still useful to observe the log messages that lead to the failure. +-- +runParDetailed :: DbgCfg -- ^ Debugging configuration + -> Int -- ^ How many worker threads to use. + -> (forall s . Par d s a) -- ^ The computation to run. + -> IO ([String], Either SomeException a) +runParDetailed dc nw (WrapPar p) = L.runParDetailed dc nw p + +-- | If a computation is guaranteed-deterministic, then `Par` becomes a dischargeable +-- effect. This function will create new worker threads and do the work in parallel, +-- returning the final result. +-- +-- (For now there is no sharing of workers with repeated invocations; so +-- keep in mind that @runPar@ is an expensive operation. [2013.09.27]) +runPar :: (forall s . Par Det s a) -> a +runPar (WrapPar p) = L.runPar p + +-- | Log a line of debugging output. This is only used when *compiled* in debugging +-- mode. It atomically adds a string onto an in-memory log. +-- +-- The provided `Int`, is the "debug level" associated with the message, 1-5. One is +-- the least verbose, and five is the most. When debugging, the user can control the +-- debug level by setting the env var DEBUG, e.g. @DEBUG=5@. +logDbgLn :: Int -> String -> Par d s () +#ifdef DEBUG_LVAR +logDbgLn n = WrapPar . L.logStrLn n +#else +logDbgLn _ _ = return () +{-# INLINE logDbgLn #-} +#endif + +-- | IF compiled with debugging support, this will return the Logger used by the +-- current Par session, otherwise it will simply throw an exception. +getLogger :: Par d s Lg.Logger +getLogger = WrapPar $ L.getLogger + +-------------------------------------------------------------------------------- +-- Extras +-------------------------------------------------------------------------------- + +{-# INLINE parForL #-} +-- | Left-biased parallel for loop. As worker threads beyond the first are added, +-- this hews closer to the sequential iteration order than an unbiased parallel loop. +-- +-- Takes a range as inclusive-start, exclusive-end. +parForL :: (Int,Int) -> (Int -> Par d s ()) -> Par d s () +parForL (start,end) _ | start > end = error$"parForL: start is greater than end: "++show (start,end) +parForL (start,end) body = do + -- logStrLn$ " initial iters: "++show (end-start) + loop 0 (end - start) 1 + where + loop offset remain chunk + | remain <= 0 = return () + | remain <= chunk = parForSimple (offset, offset+remain) body + | otherwise = do + let nxtstrt = offset+chunk + -- logStrLn$ "loop: .. "++show (offset, remain, chunk) + fork$ parForSimple (offset, nxtstrt) body + loop nxtstrt (remain-chunk) (2*chunk) + +{-# INLINE parForSimple #-} +-- | The least-sophisticated form of parallel loop. Fork iterations one at a time. +parForSimple :: (Int,Int) -> (Int -> Par d s ()) -> Par d s () +parForSimple range fn = do + for_ range $ \i -> fork (fn i) + +-- | Divide the iteration space recursively, but ultimately run every iteration in +-- parallel. That is, the loop body is permitted to block on other iterations. +parForTree :: (Int,Int) -> (Int -> Par d s ()) -> Par d s () +parForTree (start,end) _ + | start > end = error$"parForTree: start is greater than end: "++show (start,end) +parForTree (start,end) body = do + loop 0 (end - start) + where + loop offset remain + | remain == 1 = body offset + | otherwise = do + let (half,rem) = remain `quotRem` 2 + fork$ loop offset half + loop (offset+half) (half+rem) + + +-- | Split the work into a number of tiles, and fork it in a tree topology. +parForTiled :: Maybe L.HandlerPool -> Int -> (Int,Int) -> (Int -> Par d s ()) -> Par d s () +parForTiled hp otiles (start,end) body = do + loop 0 (end - start) otiles + where + loop offset remain tiles + | remain == 1 = body offset + | tiles == 1 = for_ (offset,offset+remain) body + | otherwise = do + let (half,rem) = remain `quotRem` 2 + (halfT,remT) = tiles `quotRem` 2 + forkHP hp$ loop offset half halfT + loop (offset+half) (half+rem) (halfT+remT) + + +-- | A simple for loop for numeric ranges (not requiring deforestation +-- optimizations like `forM`). Inclusive start, exclusive end. +{-# INLINE for_ #-} +for_ :: Monad m => (Int, Int) -> (Int -> m ()) -> m () +for_ (start, end) _fn | start > end = error "for_: start is greater than end" +for_ (start, end) fn = loop start + where + loop !i | i == end = return () + | otherwise = do fn i; loop (i+1) + +#ifdef GENERIC_PAR +-- | Non-blocking version of pforEach. +asyncForEachHP :: (SC.Split c, PC.Generator c) + => Maybe L.HandlerPool -- ^ Optional pool to synchronize forked tasks + -> c -- ^ element generator to consume + -> (PC.ElemOf c -> Par d s ()) -- ^ compute one result + -> Par d s () +asyncForEachHP mh gen fn = + case SC.split gen of + [seqchunk] -> PC.forM_ seqchunk fn + ls -> forM_ ls $ \ gen_i -> + forkHP mh $ + PC.forM_ gen_i fn +#endif diff --git a/Control/LVish/BulkRetry.hs b/Control/LVish/BulkRetry.hs new file mode 100644 --- /dev/null +++ b/Control/LVish/BulkRetry.hs @@ -0,0 +1,163 @@ +{-# LANGUAGE ScopedTypeVariables, BangPatterns #-} +{-# LANGUAGE DataKinds #-} + +-- | EXPERIMENTAL version which eventually should be made generic across Par monads +-- (i.e. a BulkRetryT transformer), and should thus be extended to transparently +-- catch any attempts by a thread to block, not just the special non-blocking calls +-- provided by *this* library. + +module Control.LVish.BulkRetry + + where + +import qualified Data.Bits.Atomic as B +import Foreign.Storable (sizeOf, Storable) +import Control.Monad (unless) +import Control.LVish +import Control.LVish.Internal (unsafeDet) +import Control.Par.Class (LVarSched(returnToSched)) +-- import Data.LVar.NatArray +import Data.LVar.NatArray.Unsafe (NatArray, unsafePeek) + +import Data.Par.Splittable (pforEach) +import Data.Par.Range (range) +import Data.Par.Set () -- Instances only. + +import qualified Data.Foldable as F +import qualified Data.Set as S +-- import Data.LVar.PureSet as IS +import Data.LVar.SLSet as IS +import Data.LVar.Generic (freeze) + +-- import Data.Par.Range + +-------------------------------------------------------------------------------- + +-- | The point where users send abort messages. +data RetryHub s = RetryHub (ISet s Int) -- ^ This stores the iterations that fail. + Int -- ^ This is the current iteration + +-- -- | Non-blocking get on a `NatArray`. +-- getNB :: forall s d elt . (Storable elt, B.AtomicBits elt, Num elt) => +-- RetryHub s -> NatArray s elt -> Int -> Par d s elt +-- -- LVarSched (Par d s) +-- getNB (RetryHub fails) arr ind = do +-- x <- unsafePeek arr ind +-- -- if empty, don't block, do this: +-- case x of +-- Nothing -> do logDbgLn 4 $ " [dbg-lvish] getNB: iteration failed, enqueue for retry: "++show ind +-- insert ind fails +-- returnToSched +-- Just res -> return res + + +-- | Non-blocking get on a `NatArray`. In this prototype we require that the user +-- manually CPS the computation, so that the delimited continuation between this get +-- and the end of the loop iteration is passed explicitly as an argument. +-- +-- The current reason for this compromise is that the HandlerPool mechanism is not +-- robust to us dropping the current continuation with `returnToSched`. We would +-- need a version of HandlerPool's that interoperates with a user-level callCC, that is +-- we would need something like bracket/dynamic-wind for our continuation monad. +getNB_cps :: forall s d elt . (Storable elt, B.AtomicBits elt, Num elt) => + RetryHub s + -> NatArray s elt -- ^ Array to dereference + -> Int -- ^ Which index to get + -> (elt -> Par d s ()) -- ^ Delimited continuation. + -> Par d s () +-- LVarSched (Par d s) +getNB_cps (RetryHub fails thisiter) arr ind cont = do + x <- unsafePeek arr ind + -- if empty, don't block, do this: + case x of + Nothing -> do logDbgLn 4 $ " [dbg-lvish] getNB: iteration "++ show thisiter + ++" failed, due to get on index "++show ind + insert thisiter fails + return () + Just res -> do logDbgLn 4 $ " [dbg-lvish] getNB: result available, calling continuation (iter "++show thisiter++")" + cont res +{-# INLINE getNB_cps #-} + +desired_tasks :: Int +desired_tasks = 16 -- FIXME: num procs * overpartition + +-- | A parallel for-loop which aborts and retries failed iterations in bulk, rather +-- than allowing them to "block" and suffering the overhead of capturing and storing +-- their continuations. +-- +-- `forSpeculative` continues retrying until ALL iterations have completed. It is +-- thus a *synchronous* parallel for loop. +forSpeculative :: (Int, Int) -- ^ Inclusive/Exclusive range to run. + -> (RetryHub s -> Int -> Par d s ()) -- ^ Body of the loop + -> Par d s () +-- forSpeculative :: (Int, Int) -> (RetryHub s -> Int -> Par QuasiDet s ()) -> Par QuasiDet s () +-- TODO: Requires idempotency!! +forSpeculative (st,end) bodyfn = do + logDbgLn 2 $ " [dbg-lvish] Begin forSpeculative, bounds "++show (st,end) + let sz = end - st + -- Even in a trivial loop, 2000 iters per task should be enough: + prefix = min sz (2000 * desired_tasks) + -- TODO: automatic strategies for tuning the input prefix size would be helpful. + -- One approach that might make sense would be to auto-tune based on the + -- time/iteration observed. That is, gradually increase to try to approximate a + -- minimum reasonable task size and no bigger. + + body' = bodyfn + -- body' retry ix = bodyfn retry ix + + let flush leftover fails = + -- unless (S.null leftover) $ do + -- TODO: need parallel fold, this is sequential... + F.foldlM (\ () ix -> do + logDbgLn 3 $ " [dbg-lvish] forSpeculative: flushing iter "++show ix + body' (RetryHub fails ix) ix) + () leftover + let flushLoop leftover = do + fails <- newEmptySet + -- FIXME: Add parallelism + flush leftover fails -- Sequential... + snap <- unsafeDet $ freeze fails + logDbgLn 3 $ " [dbg-lvish] forSpeculative: did one sequential flush, remaining: "++show snap + unless (S.null snap) $ + -- error$ "forSpeculative: failures not flushed with a sequential run!:\n "++show snap + flushLoop snap + + -- Outer loop of "rounds", in which we try a prefix of the iteration space. + let loop !round leftover offset 0 = do + logDbgLn 3 $ " [dbg-lvish] forSpeculative: got to the end, only failures left." + flushLoop leftover + + loop !round leftover offset remain = do + logDbgLn 3 $ " [dbg-lvish] forSpeculative starting round "++ + show round++": offset "++show offset++", remaining "++show remain + -- Set of iterations that failed in THIS upcoming round: + fails <- newEmptySet + let chunkend = offset + (min prefix remain) + + hp <- newPool + -- Here we keep the failed iterations "to the left" of the new batch, i.e. we + -- fork them first. + + -- FINISHME: need Split instance. + logDbgLn 4 $ " [dbg-lvish] forSpeculative RElaunching failures: "++show leftover + -- This version is poor because it forks on a per-iteration basis upon retry: + -- F.foldrM (\ ix () -> forkHP (Just hp) (body' (RetryHub fails ix) ix)) () leftover + -- F.foldrM (\ ix () -> body' (RetryHub fails ix) ix) () leftover + -- pforEach leftover $ bodyfn (RetryHub fails) + asyncForEachHP (Just hp) leftover $ \ ix -> bodyfn (RetryHub fails ix) ix + + -- TODO: if we keep failing it's better to expand the prefix. That way we + -- end up with a logarithmic number of retries for each iterate in the worst + -- case, rather than linear (making the whole loop unnecessarily quadratic). + + logDbgLn 4 $ " [dbg-lvish] forSpeculative launching new batch: "++show (offset,chunkend) + asyncForEachHP (Just hp) (range offset chunkend) $ \ ix -> + body' (RetryHub fails ix) ix + logDbgLn 4 $ " [dbg-lvish] forSpeculative: return from par for-loop; now quiesce." + quiesce hp + logDbgLn 4 $ " [dbg-lvish] forSpeculative: quiesce finished, next freeze failed set." + snap <- unsafeDet $ freeze fails + logDbgLn 4 $ " [dbg-lvish] forSpeculative finish round; failed iterates: "++show snap + loop (round+1) snap chunkend (remain - (chunkend - offset)) + loop 0 S.empty 0 sz + -- After the last quiesce, we're done. diff --git a/Control/LVish/Internal.hs b/Control/LVish/Internal.hs --- a/Control/LVish/Internal.hs +++ b/Control/LVish/Internal.hs @@ -24,13 +24,14 @@ -- * Unsafe conversions and lifting unWrapPar, unsafeRunPar, - unsafeConvert, state, - liftIO + unsafeConvert, unsafeDet, + state, liftIO, + -- * Debugging information taken from the environment + L.dbgLvl ) where -import Control.Monad.IO.Class import Control.LVish.MonadToss import Control.Applicative import qualified Control.LVish.SchedIdempotent as L @@ -91,8 +92,15 @@ unsafeConvert :: Par d1 s1 a -> Par d2 s2 a unsafeConvert (WrapPar p) = (WrapPar p) -instance MonadIO (Par d s) where - liftIO = WrapPar . L.liftIO +-- | Unsafe coercion from quasi-deterministic to deterministic. The user is +-- promising that code is carefully constructed so that put/freeze races will not +-- occur. +unsafeDet :: Par d1 s a -> Par d2 s a +unsafeDet (WrapPar p) = (WrapPar p) instance MonadToss (Par d s) where toss = WrapPar L.toss + +-- | Unsafe internal operation to lift IO into the Par monad. +liftIO :: IO a -> Par d s a +liftIO = WrapPar . L.liftIO diff --git a/Control/LVish/Logging.hs b/Control/LVish/Logging.hs new file mode 100644 --- /dev/null +++ b/Control/LVish/Logging.hs @@ -0,0 +1,442 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NamedFieldPuns, BangPatterns #-} + +{-| + +Thread-safe Logging with bonus controlled-schedule debugging capabilities. + +This module supports logging to memory, serializing messages and deferring the work +of actually printing them. Another thread can flush the logged messages at its +leisure. + +The second capability of this infrastructure is to use the debugging print messages +as points at which to gate the execution of the program. That is, each `logStrLn_` +call becomes a place where the program blocks and checks in with a central +coordinator, which only allows one thread to unblock at a time. Thus, if there are +sufficient debug logging messages in the program, this can enable a form of +deterministic replay (and quickcheck-style testing of different interleavings). + + -} + +module Control.LVish.Logging + ( + + -- * Global variables + dbgLvl, + + -- * New logger interface + newLogger, logOn, Logger(closeIt, flushLogs), + WaitMode(..), LogMsg(..), OutDest(..), + + -- * General utilities + forkWithExceptions + ) + where + +import Control.Monad +import qualified Control.Exception as E +import qualified Control.Concurrent.Async as A +import Data.IORef +import qualified Data.Sequence as Seq +import Data.List (sortBy) +import GHC.Conc hiding (yield) +import Control.Concurrent +import System.IO.Unsafe (unsafePerformIO) +import System.IO (stderr, stdout, hFlush, hPutStrLn, Handle) +import System.Environment(getEnvironment) +import System.Random +import Text.Printf (printf, hPrintf) +import Debug.Trace (trace, traceEventIO) + +import Control.LVish.Types +-- import qualified Control.LVish.SchedIdempotentInternal as Sched + +---------------------------------------------------------------------------------------------------- + +-- | A Logger coordinates a set of threads that print debug logging messages. +-- +-- This are abstract objects supporting only the operations provided by this module +-- and the non-hidden fields of the Logger. +data Logger = Logger { coordinator :: A.Async () -- ThreadId + -- ^ (private) The thread that chooses which action to unblock next + -- and handles printing to the screen as well. + , minLvl :: Int -- ^ The minimum level of messages accepted by this logger (usually 0). + , maxLvl :: Int -- ^ The maximum level of messages accepted by this logger. + , checkPoint :: SmplChan Writer -- ^ The serialized queue of writers attempting to log dbg messages. + , closeIt :: IO () -- ^ (public) A method to complete flushing, close down the helper thread, + -- and generally wrap up. + , loutDests :: [OutDest] -- ^ Where to send output. If empty, messages dropped entirely. + , logged :: IORef [String] -- ^ (private) In-memory buffer of messages, if OutputInMemory is selected. + -- This is stored in reverse-temporal order during execution. + , flushLogs :: IO [String] -- ^ Clear buffered log messages and return in the order they occurred. + , waitWorkers :: WaitMode + } + + +-- | A single thread attempting to log a message. It only unblocks when the attached +-- MVar is filled. +data Writer = Writer { who :: String + , continue :: MVar () + , msg :: LogMsg + -- TODO: Indicate whether this writer has useful work to do or + -- is about to block... this provides a simple notion of + -- priority. + } + +-- | Several different ways we know to wait for quiescence in the concurrent mutator +-- before proceeding. +data WaitMode = WaitTids [ThreadId] (IO Bool) + -- ^ Wait until a certain set of threads is blocked before proceeding. + -- If that conditional holds ALSO make sure the provided polling action + -- returns True as well. + | WaitDynamic -- ^ UNFINISHED: Dynamically track tasks/workers. The + -- num workers starts at 1 and then is modified + -- with `incrTasks` and `decrTasks`. + | WaitNum { + numThreads :: Int, -- ^ How many threads total must check in? + downThreads :: IO Int -- ^ Poll how many threads won't participate this round. + } -- ^ A fixed set of threads must check-in each round before proceeding. + | DontWait -- ^ In this mode, logging calls are non-blocking and return + -- immediately, rather than waiting on a central coordinator. + -- This is what we want if we're simply printing debugging output, + -- not controlling the schedule for stress testing. + deriving Show + +instance Show (IO Bool) where + show _ = "" + +instance Show (IO Int) where + show _ = "" + +-- | We allow logging in O(1) time in String or ByteString format. In practice the +-- distinction is not that important, because only *thunks* should be logged; the +-- thread printing the logs should deal with forcing those thunks. +data LogMsg = StrMsg { lvl::Int, body::String } +-- | ByteStrMsg { lvl::Int, } + +toString x@(StrMsg{}) = body x + +maxWait :: Int +maxWait = 10*1000 -- 10ms + +andM :: [IO Bool] -> IO a -> IO a -> IO a +andM [] t _f = t +andM (hd:tl) t f = do + b <- hd + if b then andM tl t f + else f + +catchAll :: ThreadId -> E.SomeException -> IO () +catchAll parent exn = + case E.fromException exn of + Just E.ThreadKilled -> return () + _ -> do + hPutStrLn stderr ("! Exception on Logger thread: "++show exn) + hFlush stderr + E.throwTo parent exn + E.throwIO exn + +-------------------------------------------------------------------------------- + +-- | Create a new logger, which includes forking a coordinator thread. +-- Takes as argument the number of worker threads participating in the computation. +newLogger :: (Int,Int) -- ^ What inclusive range of messages do we accept? Defaults to `(0,dbgLvl)`. + -> [OutDest] + -> WaitMode + -> IO Logger +newLogger (minLvl, maxLvl) loutDests waitWorkers = do + logged <- newIORef [] + checkPoint <- newSmplChan + parent <- myThreadId + let flushLogs = atomicModifyIORef' logged $ \ ls -> ([],reverse ls) + + let -- When all threads are quiescent, we can flush the remaining messagers from + -- the channel to get the whole set of waiting tasks. Return in chronological order. + flushChan !acc = do + x <- tryReadSmplChan checkPoint + case x of + Just h -> flushChan (h:acc) + Nothing -> return $ reverse acc + + -- This is the format we use for debugging messages + formatMessage extra Writer{msg} = "|"++show (lvl msg)++ "| "++extra++ toString msg + -- One of these message reports how many tasks are in parallel with it: + messageInContext pos len wr = formatMessage ("#"++show (1+pos)++" of "++show len ++": ") wr + printOne str (OutputTo h) = hPrintf h "%s\n" str + printOne str OutputEvents = traceEventIO str + printOne str OutputInMemory = + -- This needs to be atomic because other messages might be calling "flush" + -- at the same time. + atomicModifyIORef' logged $ \ ls -> (str:ls,()) + printAll str = mapM_ (printOne str) loutDests + + shutdownFlag <- newIORef False -- When true, time to shutdown. + shutdownComplete <- newEmptyMVar + + -- Here's the new thread that corresponds to this logger: + coordinator <- A.async $ E.handle (catchAll parent) $ + -- BEGIN defs for the async task: + -------------------------------------------------------------------------------- + -- Proceed in rounds, gather the set of actions that may happen in parallel, then + -- pick one. We log the series of decisions we make for reproducability. + let schedloop :: Int -> Int -- ^ length of list `waiting` + -> [Writer] -> Backoff -> IO () + schedloop !iters !num !waiting !bkoff = do + when (iters > 0 && iters `mod` 500 == 0) $ + putStrLn $ "Warning: logger has spun for "++show iters++" iterations, "++show num++" are waiting." + hFlush stdout + fl <- readIORef shutdownFlag + if fl then flushLoop + else do + let keepWaiting = do b <- backoff bkoff + schedloop (iters+1) num waiting b + waitMore = do w <- readSmplChan checkPoint -- Blocking! (or spinning) + b <- newBackoff maxWait -- We got something, reset this. + schedloop (iters+1) (num+1) (w:waiting) b + case waitWorkers of + DontWait -> error "newLogger: internal invariant broken." + WaitNum target extra -> do + n <- extra -- Atomically check how many extra workers are blocked. + if (num + n >= target) + then pickAndProceed waiting + else waitMore + WaitTids tids poll -> do + -- FIXME: This is not watertight... it will work with high probability but can't be trusted: + andM [checkTids tids, poll, checkTids tids, poll] + (do ls <- flushChan waiting + case ls of + [] -> do chatter " [Logger] Warning: No active tasks?" + bk2 <- backoff bkoff + schedloop (iters+1) 0 [] bk2 + _ -> pickAndProceed ls) + keepWaiting + + -- | Keep printing messages until there is (transiently) nothing left. + flushLoop = do + x <- tryReadSmplChan checkPoint + case x of + Just wr -> do printAll (formatMessage "" wr) + flushLoop + Nothing -> return () + + -- | A simpler alternative schedloop that only does printing (e.g. for DontWait mode). + printLoop = do + fl <- readIORef shutdownFlag + if fl then flushLoop + else do wr <- readSmplChan checkPoint + printAll (formatMessage "" wr) + printLoop + + -- Take the set of logically-in-parallel tasks, choose one, execute it, and + -- then return to the main scheduler loop. + pickAndProceed [] = error "pickAndProceed: this should only be called on a non-empty list" + pickAndProceed waiting = do + let order a b = + let s1 = toString (msg a) + s2 = toString (msg b) in + case compare s1 s2 of + GT -> GT + LT -> LT + EQ -> error $" [Logger] Need in-parallel log messages to have an ordering, got two equal:\n "++s1 + sorted = sortBy order waiting + len = length waiting + -- For now let's randomly pick an action: + pos <- randomRIO (0,len-1) + let pick = sorted !! pos + (pref,suf) = splitAt pos sorted + rst = pref ++ tail suf + unblockTask pos len pick -- The task will asynchronously run when it can. + yield -- If running on one thread, give it a chance to run. + -- Return to the scheduler to wait for the next quiescent point: + bnew <- newBackoff maxWait + schedloop 0 (length rst) rst bnew + + unblockTask pos len wr@Writer{continue} = do + printAll (messageInContext pos len wr) + putMVar continue () -- Signal that the thread may continue. + + -- Check whether the worker threads are all quiesced + checkTids [] = return True + checkTids (tid:rst) = do + st <- threadStatus tid + case st of + ThreadRunning -> return False + ThreadFinished -> checkTids rst + -- WARNING: this design is flawed because it is possible when compiled + -- with -threaded that IO will spuriously showed up as BlockedOnMVar: + ThreadBlocked BlockedOnMVar -> checkTids rst + ThreadBlocked _ -> return False + ThreadDied -> checkTids rst -- Should this be an error condition!? + in -- Main body of async task: + do case waitWorkers of + DontWait -> printLoop + _ -> schedloop (0::Int) (0::Int) [] =<< newBackoff maxWait -- Kick things off. + putMVar shutdownComplete () + return () -- End: async thread + -- END async task. + -------------------------------------------------------------------------------- + + let closeIt = do + atomicModifyIORef' shutdownFlag (\_ -> (True,())) + readMVar shutdownComplete + A.cancel coordinator -- Just to make sure its completely done. + return $! Logger { coordinator, checkPoint, closeIt, loutDests, + logged, flushLogs, + waitWorkers, minLvl, maxLvl } + +chatter :: String -> IO () +-- chatter = hPrintf stderr +-- chatter = printf "%s\n" +chatter _ = return () + +printNTrace s = do putStrLn s; traceEventIO s; hFlush stdout + +-- UNFINISHED: +incrTasks = undefined +decrTasks = undefined + +-- | Write a log message from the current thread, IF the level of the +-- message falls into the range accepted by the given `Logger`, +-- otherwise, the message is ignored. +logOn :: Logger -> LogMsg -> IO () +logOn Logger{checkPoint,minLvl,maxLvl,waitWorkers} msg + | (minLvl <= lvl msg) && (lvl msg <= maxLvl) = do + case waitWorkers of + -- In this mode we are non-blocking: + DontWait -> writeSmplChan checkPoint Writer{who="",continue=dummyMVar,msg} + _ -> do continue <- newEmptyMVar + writeSmplChan checkPoint Writer{who="",continue,msg} + takeMVar continue -- Block until we're given permission to proceed. + | otherwise = return () + +{-# NOINLINE dummyMVar #-} +dummyMVar :: MVar () +dummyMVar = unsafePerformIO newEmptyMVar + +---------------------------------------------------------------------------------------------------- +-- Simple back-off strategy. + +-- | The state for an exponential backoff. +data Backoff = Backoff { current :: !Int + , cap :: !Int -- ^ Maximum nanoseconds to wait. + } + deriving Show + + +newBackoff :: Int -> IO Backoff +newBackoff cap = return Backoff{cap,current=0} + +backoff :: Backoff -> IO Backoff +-- backoff b = do yield; return b +backoff Backoff{current,cap} = + case current of + -- Yield once before we start delaying: + 0 -> do yield + return Backoff{cap,current=1} + n -> do let next = min cap (2*n) + threadDelay n + return Backoff{cap,current=next} + +---------------------------------------------------------------------------------------------------- +-- Simple channels: we need non-blocking reads so we can't use +-- Control.Concurrent.Chan. We could use TChan, but I don't want to bring STM into +-- it right now. + +-- type MyChan a = Chan a + +-- -- | A simple channel. Take-before-put is the protocol. +-- type SmplChan a = MVar [a] + +-- | Simple channels that don't support real blocking. +type SmplChan a = IORef (Seq.Seq a) -- New elements pushed on right. + +newSmplChan :: IO (SmplChan a) +newSmplChan = newIORef Seq.empty + +-- | Non-blocking read. +tryReadSmplChan :: SmplChan a -> IO (Maybe a) +tryReadSmplChan ch = do + x <- atomicModifyIORef' ch $ \ sq -> + case Seq.viewl sq of + Seq.EmptyL -> (Seq.empty, Nothing) + h Seq.:< t -> (t, Just h) + return x + +-- | A synchronous read that must block or busy-wait until a value is available. +readSmplChan :: SmplChan a -> IO a +readSmplChan ch = loop =<< newBackoff maxWait + where + loop bk = do + x <- tryReadSmplChan ch + case x of + Nothing -> do b2 <- backoff bk + loop b2 + Just h -> return h + +-- | Always succeeds. Asynchronous write to channel. +writeSmplChan :: SmplChan a -> a -> IO () +writeSmplChan ch x = do + atomicModifyIORef' ch $ \ s -> (s Seq.|> x,()) + +---------------------------------------------------------------------------------------------------- + +{-# NOINLINE theEnv #-} +theEnv :: [(String, String)] +theEnv = unsafePerformIO getEnvironment + +-- | Debugging flag shared by several modules. +-- This is activated by setting the environment variable @DEBUG=1..5@. +-- +-- By convention @DEBUG=100@ turns on full sequentialization of the program and +-- control over the interleavings in concurrent code, enabling systematic debugging +-- of concurrency problems. +dbgLvl :: Int +#ifdef DEBUG_LVAR +{-# NOINLINE dbgLvl #-} +dbgLvl = case lookup "DEBUG" theEnv of + Nothing -> defaultDbg + Just "" -> defaultDbg + Just "0" -> defaultDbg + Just s -> + case reads s of + ((n,_):_) -> trace (" [!] LVish responding to env Var: DEBUG="++show n) n + [] -> error$"Attempt to parse DEBUG env var as Int failed: "++show s +#else +{-# INLINE dbgLvl #-} +dbgLvl = 0 +#endif + +defaultDbg :: Int +defaultDbg = 0 + +replayDbg :: Int +replayDbg = 100 + + +-- | Exceptions that walk up the fork-tree of threads. +-- +-- WARNING: By holding onto the ThreadId we keep the parent thread from being +-- garbage collected (at least as of GHC 7.6). This means that even if it was +-- complete, it will still be hanging around to accept the exception below. +forkWithExceptions :: (IO () -> IO ThreadId) -> String -> IO () -> IO ThreadId +forkWithExceptions forkit descr action = do + parent <- myThreadId + forkit $ do + tid <- myThreadId + E.catch action + (\ e -> + case E.fromException e of + Just E.ThreadKilled -> do +-- Killing worker threads is normal now when exception handling, so this chatter is restricted to debug mode: +#ifdef DEBUG_LVAR + printf "\nThreadKilled exception inside child thread, %s (not propagating!): %s\n" (show tid) (show descr) +#endif + return () + _ -> do +#ifdef DEBUG_LVAR + printf "\nException inside child thread %s, %s: %s\n" (show descr) (show tid) (show e) +#endif + E.throwTo parent (e :: E.SomeException) + ) diff --git a/Control/LVish/Logical.hs b/Control/LVish/Logical.hs new file mode 100644 --- /dev/null +++ b/Control/LVish/Logical.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE BangPatterns #-} + +-- | Not exported directly. Reexported by "Control.LVish". +module Control.LVish.Logical (asyncAnd, asyncOr, andMap, orMap) where + +import Control.LVish.Basics +import Control.LVish.Internal (Par(WrapPar), unsafeDet) +import Control.LVish.SchedIdempotent (liftIO, HandlerPool) +import Data.LVar.IVar as IV + +import qualified Data.Atomics.Counter as C + +-------------------------------------------------------------------------------- + +-- | A parallel @And@ operation that can return early---whenever a False appears on either branch. +asyncAnd :: Maybe HandlerPool -> (Par d s Bool) -> (Par d s Bool) -> (Bool -> Par d s ()) -> Par d s () +asyncAnd hp leftM rightM kont = do + -- Atomic counter, if we are the second True we write the result: + cnt <- io$ C.newCounter 0 -- TODO we could share this for 3+-way and. + let launch m = forkHP hp $ + do b <- m + case b of + True -> do n <- io$ C.incrCounter 1 cnt + if n==2 + then kont True + else return () + False -> -- We COULD assume idempotency and execute kont False twice, + -- but since we have the counter anyway let us dedup: + do n <- io$ C.incrCounter 100 cnt + if n < 200 -- Zero ops or one True. + then kont False + else return () + launch leftM + launch rightM + return () + +-- OR this could expose: +-- asyncAnd :: Maybe HandlerPool -> (Par d s Bool) -> (Par d s Bool) -> Par d s Bool + + +-- +-- I think this is one of those situations where (efficiently) abstracting is more +-- complicated than permitting a code clone. + +-- | Analagous operation for @Or@. +asyncOr :: Maybe HandlerPool -> (Par d s Bool) -> (Par d s Bool) -> (Bool -> Par d s ()) -> Par d s () +asyncOr hp leftM rightM kont = do + -- Atomic counter, if we`re the second True we write the result: + cnt <- io$ C.newCounter 0 -- TODO we could share this for 3+-way and. + let launch m = forkHP hp $ + do b <- m + case b of + False -> do n <- io$ C.incrCounter 1 cnt + if n==2 + then kont False + else return () + True -> -- We COULD assume idempotency and execute kont False twice, + -- but since we have the counter anyway let`s dedup: + do n <- io$ C.incrCounter 100 cnt + if n < 200 -- Zero ops or one True. + then kont True + else return () + launch leftM + launch rightM + return () +-- + +-------------------------------------------------------------------------------- +-- Lift them to lists: +-------------------------------------------------------------------------------- + +{-# INLINE andMap #-} +andMap :: Maybe HandlerPool -> (a -> Par d s Bool) -> [a] -> Par d s Bool +andMap = makeMapper asyncAnd + +{-# INLINE orMap #-} +orMap :: Maybe HandlerPool -> (a -> Par d s Bool) -> [a] -> Par d s Bool +orMap = makeMapper asyncOr + +{-# INLINE makeMapper #-} +makeMapper :: (Maybe HandlerPool -> (Par d s Bool) -> (Par d s Bool) -> (Bool -> Par d s ()) -> Par d s ()) -> + Maybe HandlerPool -> (a -> Par d s Bool) -> [a] -> Par d s Bool +makeMapper asyncOp hp fn ls = aloop ls + where + aloop [] = return True + aloop [x] = fn x + aloop ls2 = do let (x,y) = fastChop ls2 + tmp <- IV.new -- A place for the intermediate result + asyncOp hp (aloop x) (aloop y) (IV.put tmp) -- writeIt + IV.get tmp -- IM.getKey thekey table + + + +-------------------------------------------------------------------------------- +-- Utilities: +-------------------------------------------------------------------------------- + +fastChop :: [a] -> ([a],[a]) +fastChop ls = loop [] ls ls + where + loop !acc !rst1 !rst2 = + case rst2 of + [] -> (acc,rst1) + [_] -> (acc,rst1) + -- Each time around we chop one from rst1 and two from rst2: + _:_:rst2' -> let (hd:rst1') = rst1 in + loop (hd:acc) rst1' rst2' + + +io :: IO a -> Par d s a +io = WrapPar . liftIO + diff --git a/Control/LVish/SchedIdempotent.hs b/Control/LVish/SchedIdempotent.hs --- a/Control/LVish/SchedIdempotent.hs +++ b/Control/LVish/SchedIdempotent.hs @@ -21,32 +21,39 @@ module Control.LVish.SchedIdempotent ( -- * Basic types and accessors - LVar(), state, HandlerPool(), + LVar(..), state, HandlerPool(), Par(..), ClosedPar(..), -- * Safe, deterministic operations yield, newPool, fork, forkHP, - runPar, runParIO, runParLogged, + runPar, runParIO, + runParDetailed, runParLogged, withNewPool, withNewPool_, forkWithExceptions, -- * Quasi-deterministic operations quiesce, quiesceAll, - -- * Debug facilities - logStrLn, dbgLvl, + -- * Re-exported debug facilities + logStrLn, dbgLvl, getLogger, -- * Unsafe operations; should be used only by experts to build new abstractions newLV, getLV, putLV, putLV_, freezeLV, freezeLVAfter, - addHandler, liftIO, toss + addHandler, liftIO, toss, + + -- * Internal, private bits. + mkPar, Status(..), sched, Listener(..) ) where import Control.Monad hiding (sequence, join) import Control.Concurrent hiding (yield) +import qualified Control.Concurrent as Conc import qualified Control.Exception as E import Control.DeepSeq import Control.Applicative import Control.LVish.MonadToss +import Control.LVish.Logging as L +import Debug.Trace(trace) import Data.IORef import Data.Atomics import Data.Typeable @@ -57,8 +64,8 @@ import System.IO.Unsafe (unsafePerformIO) import System.Environment(getEnvironment) import System.Mem.StableName (makeStableName, hashStableName) -import Debug.Trace(trace) import Prelude hiding (mapM, sequence, head, tail) +import qualified Prelude import System.Random (random) #ifdef DEBUG_LVAR @@ -66,89 +73,11 @@ #endif -- import Control.Compose ((:.), unO) -import Data.Traversable +import Data.Traversable import Control.LVish.Types import qualified Control.LVish.SchedIdempotentInternal as Sched - ----------------------------------------------------------------------------------------------------- --- THREAD-SAFE LOGGING ----------------------------------------------------------------------------------------------------- - --- This should probably be moved into its own module... - -globalLog :: IORef [String] -globalLog = unsafePerformIO $ newIORef [] - --- | Atomically add a line to the given log. -logStrLn :: String -> Par () -logStrLn_ :: String -> IO () -logLnAt_ :: Int -> String -> IO () -#ifdef DEBUG_LVAR -#warning "Compiling in LVish DEBUG mode." -logStrLn = liftIO . logStrLn_ -logStrLn_ s = logLnAt_ 1 s -logLnAt_ lvl s | dbgLvl >= 5 = putStrLn s - | dbgLvl >= lvl = atomicModifyIORef globalLog $ \ss -> (s:ss, ()) - | otherwise = return () -#else -logStrLn _ = return () -logStrLn_ _ = return () -logLnAt_ _ _ = return () -{-# INLINE logStrLn #-} -{-# INLINE logStrLn_ #-} -#endif - --- | Print all accumulated log lines. -printLog :: IO () -printLog = do - -- Clear the log when we read it: - lines <- atomicModifyIORef globalLog $ \ss -> ([], ss) - mapM_ putStrLn $ reverse lines - -printLogThread :: IO (IO ()) -printLogThread = do - tid <- forkIO $ - E.catch loop (\ (e :: E.AsyncException) -> do - -- One last time on kill: - printLog - putStrLn " [dbg-log-printer] Shutting down." - ) - return (do killThread tid - let wait = do - stat <- threadStatus tid - case stat of - ThreadRunning -> threadDelay 1000 >> wait - _ -> return () - wait) - where - loop = do - -- Flush the log at 5Hz: - printLog - threadDelay (200 * 1000) - loop - -{-# NOINLINE theEnv #-} -theEnv :: [(String, String)] -theEnv = unsafePerformIO getEnvironment - -{-# NOINLINE dbgLvl #-} --- | Debugging flag shared by several modules. --- This is activated by setting the environment variable @DEBUG=1..5@. -dbgLvl :: Int -dbgLvl = case lookup "DEBUG" theEnv of - Nothing -> defaultDbg - Just "" -> defaultDbg - Just "0" -> defaultDbg - Just s -> - case reads s of - ((n,_):_) -> trace (" [!] Responding to env Var: DEBUG="++show n) n - [] -> error$"Attempt to parse DEBUG env var as Int failed: "++show s - -defaultDbg :: Int -defaultDbg = 0 - ------------------------------------------------------------------------------ -- LVar and Par monad representation ------------------------------------------------------------------------------ @@ -183,6 +112,7 @@ -- represent Maybe (LVarID) with the type LVarID -- i.e., without any allocation. noName :: LVarID noName = unsafePerformIO $ newLVID +{-# NOINLINE noName #-} -- | The frozen bit of an LVar is tied together with the bag of waiting listeners, -- which allows the entire bag to become garbage immediately after freezing. @@ -190,8 +120,9 @@ -- may still reference the bag, which is necessary to ensure that all listeners -- are informed of the @put@ prior to freezing.) data Status d - = Frozen -- further changes to the state are forbidden - | Active (B.Bag (Listener d)) -- bag of blocked threshold reads and handlers + = Freezing -- ^ further changes to the state are forbidden + | Frozen -- ^ further changes to the state are forbidden + | Active (B.Bag (Listener d)) -- ^ bag of blocked threshold reads and handlers -- | A listener for an LVar is informed of each change to the LVar's state -- (represented as a delta) and the event of the LVar freezing. The listener is @@ -258,8 +189,30 @@ curStatus <- readIORef status case curStatus of Active _ -> return False - Frozen -> return True - + _ -> return True + +-- | Logging within the (internal) Par monad. +logStrLn :: Int -> String -> Par () +#ifdef DEBUG_LVAR +-- logStrLn = liftIO . logStrLn_ +logStrLn lvl str = when (dbgLvl >= 1) $ do + lgr <- getLogger + num <- getWorkerNum + liftIO$ L.logOn lgr (L.StrMsg lvl ("(wrkr"++show num ++") "++ str)) +#else +logStrLn _ _ = return () +#endif + +logWith :: Sched.State a s -> Int -> String -> IO () +#ifdef DEBUG_LVAR +-- Only when the debug level is 1 or higher is the logger even initialized: +logWith q lvl str = when (dbgLvl >= 1) $ do + Just lgr <- readIORef (Sched.logger q) + L.logOn lgr (L.StrMsg lvl str) +#else +logWith _ _ _ = return () +#endif + ------------------------------------------------------------------------------ -- LVar operations ------------------------------------------------------------------------------ @@ -285,16 +238,13 @@ -- that, if we are not currently above the threshhold, we will have to poll -- /again/ after enrolling the callback. This race may also result in the -- continuation being executed twice, which is permitted by idempotence. - + let uniqsuf = ", lv "++(show$ unsafeName state)++" on worker "++(show$ Sched.no q) + + logWith q 7$ " [dbg-lvish] getLV: first readIORef "++uniqsuf curStatus <- readIORef status case curStatus of - Frozen -> do - tripped <- globalThresh state True - case tripped of - Just b -> exec (k b) q -- already past the threshold; invoke the - -- continuation immediately - Nothing -> sched q Active listeners -> do + logWith q 7$ " [dbg-lvish] getLV (active): check globalThresh"++uniqsuf tripped <- globalThresh state False case tripped of Just b -> exec (k b) q -- already past the threshold; invoke the @@ -310,52 +260,85 @@ onFreeze = unblockWhen $ globalThresh state True unblockWhen thresh tok q = do + let uniqsuf = ", lv "++(show$ unsafeName state)++" on worker "++(show$ Sched.no q) + logWith q 7$ " [dbg-lvish] getLV (active): callback: check thresh"++uniqsuf tripped <- thresh whenJust tripped $ \b -> do B.remove tok #if GET_ONCE + logWith q 8$ " [dbg-lvish] getLV (active): read execFlag for dedup"++uniqsuf ticket <- readForCAS execFlag unless (peekTicket ticket) $ do - (winner, _) <- casIORef execFlag ticket True + (winner, _) <- do logWith q 8$ " [dbg-lvish] getLV (active): CAS execFlag dedup"++uniqsuf + casIORef execFlag ticket True when winner $ Sched.pushWork q (k b) #else Sched.pushWork q (k b) #endif - + logWith q 4$ " [dbg-lvish] getLV: blocking on LVar, registering listeners"++uniqsuf -- add listener, i.e., move the continuation to the waiting bag tok <- B.put listeners $ Listener onUpdate onFreeze -- but there's a race: the threshold might be passed (or the LVar -- frozen) between our check and the enrollment as a listener, so we -- must poll again + logWith q 8$ " [dbg-lvish] getLV (active): second frozen check"++uniqsuf frozen <- isFrozen lv + logWith q 7$ " [dbg-lvish] getLV (active): second globalThresh check"++uniqsuf tripped' <- globalThresh state frozen case tripped' of Just b -> do + logWith q 7$ " [dbg-lvish] getLV (active): second globalThresh tripped, remove tok"++uniqsuf B.remove tok -- remove the listener we just added, and exec (k b) q -- execute the continuation. this work might be -- redundant, but by idempotence that's OK Nothing -> sched q + -- Freezing or Frozen: + _ -> do + logWith q 7$ " [dbg-lvish] getLV (frozen): about to check globalThresh"++uniqsuf + tripped <- globalThresh state True + case tripped of + Just b -> do -- logWith q 9$ " [dbg-lvish] getLV (frozen): thresh met, invoking continuation "++uniqsuf + exec (k b) q -- already past the threshold; invoke the + -- continuation immediately + Nothing -> sched q -- We'll NEVER be above the threshold. + -- Shouldn't this be an ERROR? (blocked-indefinitely) + -- Depends on our semantics for runPar quiescence / errors states. -- | Update an LVar. putLV_ :: LVar a d -- ^ the LVar -> (a -> Par (Maybe d, b)) -- ^ how to do the put, and whether the LVar's -- value changed -> Par b -putLV_ LVar {state, status, name} doPut = mkPar $ \k q -> do - Sched.setStatus q name -- publish our intent to modify the LVar - let cont (delta, ret) = ClosedPar $ \q -> do - curStatus <- readIORef status -- read the frozen bit *while q's status is marked* - Sched.setStatus q noName -- retract our modification intent - whenJust delta $ \d -> do - case curStatus of - Frozen -> E.throw$ PutAfterFreezeExn "Attempt to change a frozen LVar" - Active listeners -> - B.foreach listeners $ \(Listener onUpdate _) tok -> onUpdate d tok q - exec (k ret) q - exec (close (doPut state) cont) q -- possibly modify the LVar - +putLV_ LVar {state, status, name} doPut = mkPar $ \k q -> do + let uniqsuf = ", lv "++(show$ unsafeName state)++" on worker "++(show$ Sched.no q) + putAfterFrzExn = E.throw$ PutAfterFreezeExn "Attempt to change a frozen LVar" + logWith q 8 $ " [dbg-lvish] putLV: initial lvar status read"++uniqsuf + fstStatus <- readIORef status + case fstStatus of + Freezing -> putAfterFrzExn + Frozen -> putAfterFrzExn + Active listeners -> do + logWith q 8 $ " [dbg-lvish] putLV: setStatus,"++uniqsuf + Sched.setStatus q name -- publish our intent to modify the LVar + let cont (delta, ret) = ClosedPar $ \q -> do + logWith q 8 $ " [dbg-lvish] putLV: read final status before unsetting"++uniqsuf + sndStatus <- readIORef status -- read the frozen bit *while q's status is marked* + logWith q 8 $ " [dbg-lvish] putLV: UN-setStatus"++uniqsuf + Sched.setStatus q noName -- retract our modification intent + -- AFTER the retraction, freezeLV is allowed to set the state to Frozen. + whenJust delta $ \d -> do + case sndStatus of + Frozen -> putAfterFrzExn + _ -> do + logWith q 9 $ " [dbg-lvish] putLV: calling each listener's onUpdate"++uniqsuf + B.foreach listeners $ \(Listener onUpdate _) tok -> onUpdate d tok q + exec (k ret) q + logWith q 5 $ " [dbg-lvish] putLV: about to mutate lvar"++uniqsuf + exec (close (doPut state) cont) q + + -- | Update an LVar without generating a result. putLV :: LVar a d -- ^ the LVar -> (a -> IO (Maybe d)) -- ^ how to do the put, and whether the LVar's @@ -368,13 +351,20 @@ -- It is the data structure implementor's responsibility to expose this as quasi-deterministc. freezeLV :: LVar a d -> Par () freezeLV LVar {name, status} = mkPar $ \k q -> do - oldStatus <- atomicModifyIORef status $ \s -> (Frozen, s) + let uniqsuf = ", lv "++(show$ unsafeName state)++" on worker "++(show$ Sched.no q) + logWith q 5 $ " [dbg-lvish] freezeLV: atomic modify status to Freezing"++uniqsuf + oldStatus <- atomicModifyIORef status $ \s -> (Freezing, s) case oldStatus of - Frozen -> return () + Frozen -> return () + Freezing -> return () Active listeners -> do + logWith q 7 $ " [dbg-lvish] freezeLV: begin busy-wait for putter status"++uniqsuf Sched.await q (name /=) -- wait until all currently-running puts have -- snapshotted the active status + logWith q 7 $ " [dbg-lvish] freezeLV: calling each listener's onFreeze"++uniqsuf B.foreach listeners $ \Listener {onFreeze} tok -> onFreeze tok q + logWith q 7 $ " [dbg-lvish] freezeLV: finalizing status as Frozen"++uniqsuf + writeIORef status Frozen exec (k ()) q ------------------------------------------------------------------------------ @@ -387,7 +377,7 @@ cnt <- C.new bag <- B.new let hp = HandlerPool cnt bag - hpMsg " [dbg-lvish] Created new pool" hp + hpMsg q " [dbg-lvish] Created new pool" hp exec (k hp) q -- | Convenience function. Execute a @Par@ computation in the context of a fresh handler pool. @@ -431,7 +421,7 @@ C.dec cnt -- record handler completion in pool quiescent <- C.poll cnt -- check for (transient) quiescence when quiescent $ do -- wake any threads waiting on quiescence - hpMsg " [dbg-lvish] -> Quiescent now.. waking conts" hp + hpMsg q " [dbg-lvish] -> Quiescent now.. waking conts" hp let invoke t tok = do B.remove tok Sched.pushWork q t @@ -446,55 +436,67 @@ {-# INLINE addHandler #-} addHandler :: Maybe HandlerPool -- ^ pool to enroll in, if any -> LVar a d -- ^ LVar to listen to - -> (a -> IO (Maybe (Par ()))) -- ^ initial callback + -> (a -> Par ()) -- ^ initial snapshot callback on handler registration -> (d -> IO (Maybe (Par ()))) -- ^ subsequent callbacks: updates -> Par () -addHandler hp LVar {state, status} globalThresh updateThresh = +addHandler hp LVar {state, status} globalCB updateThresh = let spawnWhen thresh q = do tripped <- thresh whenJust tripped $ \cb -> do + logWith q 5 " [dbg-lvish] addHandler: Delta threshold triggered, pushing work.." closed <- closeInPool hp cb - Sched.pushWork q closed + Sched.pushWork q closed onUpdate d _ q = spawnWhen (updateThresh d) q - onFreeze _ _ = return () + onFreeze _ _ = return () + + runWhen thresh q = do + tripped <- thresh + whenJust tripped $ \cb -> + exec (close cb nullCont) q in mkPar $ \k q -> do curStatus <- readIORef status case curStatus of Active listeners -> -- enroll the handler as a listener do B.put listeners $ Listener onUpdate onFreeze; return () - Frozen -> return () -- frozen, so no need to enroll - spawnWhen (globalThresh state) q -- poll globally to see whether we should - -- launch any callbacks now + Frozen -> return () -- frozen, so no need to enroll + Freezing -> return () -- frozen, so no need to enroll + + logWith q 4 " [dbg-lvish] addHandler: calling globalCB.." + -- At registration time, traverse (globally) over the previously inserted items + -- to launch any required callbacks. + exec (close (globalCB state) nullCont) q exec (k ()) q +nullCont = (\() -> ClosedPar (\_ -> return ())) + -- | Block until a handler pool is quiescent. quiesce :: HandlerPool -> Par () quiesce hp@(HandlerPool cnt bag) = mkPar $ \k q -> do - hpMsg " [dbg-lvish] Begin quiescing pool, identity= " hp + hpMsg q " [dbg-lvish] Begin quiescing pool, identity= " hp -- tradeoff: we assume that the pool is not yet quiescent, and thus enroll as -- a blocked thread prior to checking for quiescence tok <- B.put bag (k ()) quiescent <- C.poll cnt if quiescent then do B.remove tok - hpMsg " [dbg-lvish] -> Quiescent already!" hp + hpMsg q " [dbg-lvish] -> Quiescent already!" hp exec (k ()) q else do - hpMsg " [dbg-lvish] -> Not quiescent yet, back to sched" hp + hpMsg q " [dbg-lvish] -> Not quiescent yet, back to sched" hp sched q -- | A global barrier. quiesceAll :: Par () quiesceAll = mkPar $ \k q -> do sched q - logStrLn_ " [dbg-lvish] Return from global barrier." + logWith q 1 " [dbg-lvish] Return from global barrier." exec (k ()) q -- | Freeze an LVar after a given handler quiesces. -- This is quasi-deterministic. freezeLVAfter :: LVar a d -- ^ the LVar of interest - -> (a -> IO (Maybe (Par ()))) -- ^ initial callback + -> (a -> Par ()) -- ^ initial snapshot callback on handler registration -> (d -> IO (Maybe (Par ()))) -- ^ subsequent callbacks: updates -> Par () freezeLVAfter lv globalCB updateCB = do @@ -516,7 +518,7 @@ forkHP mh child = mkPar $ \k q -> do closed <- closeInPool mh child Sched.pushWork q (k ()) -- "Work-first" policy. --- hpMsg " [dbg-lvish] incremented and pushed work in forkInPool, now running cont" hp +-- hpMsg q " [dbg-lvish] incremented and pushed work in forkInPool, now running cont" hp exec closed q -- | Fork a child thread. @@ -528,7 +530,18 @@ liftIO io = mkPar $ \k q -> do r <- io exec (k r) q - + +-- | IF compiled with debugging support, this will return the Logger used by the +-- current Par session, otherwise it will simply throw an exception. +getLogger :: Par L.Logger +getLogger = mkPar $ \k q -> do + Just lgr <- readIORef (Sched.logger q) + exec (k lgr) q + +-- | Return the worker that we happen to be running on. (NONDETERMINISTIC.) +getWorkerNum :: Par Int +getWorkerNum = mkPar $ \k q -> exec (k (Sched.no q)) q + -- | Generate a random boolean in a core-local way. Fully nondeterministic! instance MonadToss Par where toss = mkPar $ \k q -> do @@ -544,6 +557,8 @@ sched q {-# INLINE sched #-} +-- | Contract: This scheduler function only returns when ALL worker threads have +-- completed their work and idled. sched :: SchedState -> IO () sched q = do n <- Sched.next q @@ -555,64 +570,95 @@ instance NFData (LVar a d) where rnf _ = () -runPar_internal :: Par a -> IO a -runPar_internal c = do - closeLogger <- if dbgLvl >= 1 - then printLogThread - else return (return ()) - res <- runPar_internal2 c - -- printLog - closeLogger - hFlush stdout - return res -runPar_internal2 :: Par a -> IO a -runPar_internal2 c = do - queues <- Sched.new numCapabilities noName +-- | A variant with full control over the relevant knobs. +-- +-- Returns a list of flushed debug messages at the end (if in-memory logging was +-- enabled, otherwise the list is empty). +-- +-- This version of runPar catches ALL exceptions that occur within the runPar, and +-- returns them via an Either. The reason for this is that even if an error +-- occurs, it is still useful to observe the log messages that lead to the failure. +-- +runParDetailed :: DbgCfg -- ^ Debugging config + -> Int -- ^ How many worker threads to use. + -> Par a -- ^ The computation to run. + -> IO ([String], Either E.SomeException a) +runParDetailed DbgCfg {dbgRange, dbgDests, dbgScheduling } numWrkrs comp = do + queues <- Sched.new numWrkrs noName -- We create a thread on each CPU with forkOn. The CPU on which -- the current thread is running will host the main thread; the -- other CPUs will host worker threads. main_cpu <- Sched.currentCPU answerMV <- newEmptyMVar + wrkrtids <- newIORef [] + -- Debugging: spin the main thread (not beginning work) until we can fully + -- initialize the logging data structure. + -- + -- TODO: This would be easier to deal with if we used the current thread directly + -- as the main worker thread... + let setLogger = do + ls <- readIORef wrkrtids + if length ls == numWrkrs + then Sched.initLogger queues ls (minLvl,maxLvl) dbgDests dbgScheduling + else do Conc.yield + setLogger + (minLvl, maxLvl) = case dbgRange of + Just b -> b + Nothing -> (0,dbgLvl) + -- Option 1: forkWithExceptions version: + ---------------------------------------------------------------------------------- #if 1 - wrkrtids <- newIORef [] let forkit = forM_ (zip [0..] queues) $ \(cpu, q) -> do - tid <- forkWithExceptions (forkOn cpu) "worker thread" $ + tid <- L.forkWithExceptions (forkOn cpu) "worker thread" $ do if cpu == main_cpu then let k x = ClosedPar $ \q -> do sched q -- ensure any remaining, enabled threads run to putMVar answerMV x -- completion prior to returning the result -- [TODO: ^ perhaps better to use a binary notification tree to signal the workers to stop...] - in exec (close c k) q + in do +#ifdef DEBUG_LVAR + -- This is painful, we may need to spin and wait for everybody to be forked: + when (maxLvl >= 1) setLogger +#endif + exec (close comp k) q -- Note: The above is important: it is sketchy to leave any workers running after -- the main thread exits. Subsequent exceptions on child threads, even if -- forwarded asynchronously, can arrive much later at the main thread -- (e.g. after it has exited, or set up a new handler, etc). else sched q atomicModifyIORef_ wrkrtids (tid:) - logStrLn_ " [dbg-lvish] About to fork workers..." - ans <- E.catch (forkit >> takeMVar answerMV) + -- logWith (Prelude.head queues) " [dbg-lvish] About to fork workers..." + ans <- E.catch (forkit >> fmap Right (takeMVar answerMV)) (\ (e :: E.SomeException) -> do tids <- readIORef wrkrtids - logStrLn_$ " [dbg-lvish] Killing off workers due to exception: "++show tids + logWith (Prelude.head queues) 1 $ " [dbg-lvish] Killing off workers due to exception: "++show tids mapM_ killThread tids -- if length tids < length queues then do -- TODO: we could try to chase these down in the idle list. mytid <- myThreadId - when (dbgLvl >= 1) printLog -- Unfortunately this races with the log printing thread. - E.throw$ LVarSpecificExn ("EXCEPTION in runPar("++show mytid++"): "++show e) + -- when (maxLvl >= 1) printLog -- Unfortunately this races with the log printing thread. + -- E.throw$ LVarSpecificExn ("EXCEPTION in runPar("++show mytid++"): "++show e) + return $! Left e ) - logStrLn_ " [dbg-lvish] parent thread escaped unscathed" - return ans + logWith (Prelude.head queues) 1 " [dbg-lvish] parent thread escaped unscathed" + mlgr <- readIORef (Sched.logger (Prelude.head queues)) + logs <- case mlgr of + Nothing -> return [] + Just lgr -> do L.closeIt lgr + L.flushLogs lgr -- If in-memory logging is off, this will be empty. + return $! (logs,ans) #else +-- Option 2: This was an experiment to use Control.Concurrent.Async to deal with exceptions: +---------------------------------------------------------------------------------- let runWorker (cpu, q) = do if (cpu /= main_cpu) then sched q else let k x = ClosedPar $ \q -> do sched q -- ensure any remaining, enabled threads run to putMVar answerMV x -- completion prior to returning the result - in exec (close c k) q + in exec (close comp k) q -- Here we want a traditional, fork-join parallel loop with proper exception handling: let loop [] asyncs = mapM_ wait asyncs @@ -638,27 +684,42 @@ takeMVar answerMV #endif +defaultRun :: Par b -> IO b +defaultRun = fmap (fromRight . snd) . + runParDetailed cfg numCapabilities + where + cfg = DbgCfg { dbgRange = Just (0,dbgLvl) + , dbgDests = [L.OutputTo stderr, L.OutputEvents] + , dbgScheduling = False } -- | Run a deterministic parallel computation as pure. runPar :: Par a -> a -runPar = unsafePerformIO . runPar_internal +runPar = unsafePerformIO . defaultRun -- | A version that avoids an internal `unsafePerformIO` for calling -- contexts that are already in the `IO` monad. runParIO :: Par a -> IO a -runParIO = runPar_internal +runParIO = defaultRun -- | Debugging aid. Return debugging logs, in realtime order, in addition to the --- final result. +-- final result. This is like `runParDetailed` but uses the default settings. runParLogged :: Par a -> IO ([String],a) -runParLogged c = - do res <- runPar_internal2 c - lines <- atomicModifyIORef globalLog $ \ss -> ([], ss) - return (reverse lines, res) +runParLogged comp = do + (logs,ans) <- runParDetailed + DbgCfg { dbgRange = (Just (0,dbgLvl)) + , dbgDests = [L.OutputEvents, L.OutputInMemory] + , dbgScheduling = False } + numCapabilities comp + return $! (logs,fromRight ans) +-- | Convert from a Maybe back to an exception. +fromRight :: Either E.SomeException a -> a +fromRight (Right x) = x +fromRight (Left e) = E.throw e + {-# INLINE atomicModifyIORef_ #-} atomicModifyIORef_ :: IORef a -> (a -> a) -> IO () -atomicModifyIORef_ ref fn = atomicModifyIORef ref (\ x -> (fn x,())) +atomicModifyIORef_ ref fn = atomicModifyIORef' ref (\ x -> (fn x,())) {-# NOINLINE unsafeName #-} unsafeName :: a -> Int @@ -667,14 +728,21 @@ return (hashStableName sn) {-# INLINE hpMsg #-} -hpMsg msg hp = - when (dbgLvl >= 3) $ do +hpMsg :: Sched.State a s -> String -> HandlerPool -> IO () +hpMsg q msg hp = do +#ifdef DEBUG_LVAR s <- hpId_ hp - logLnAt_ 3 $ msg++", pool identity= " ++s + logWith q 3 $ msg++", pool identity= " ++s +#else + return () +#endif {-# NOINLINE hpId #-} +hpId :: HandlerPool -> String hpId hp = unsafePerformIO (hpId_ hp) +-- | Debugging tool for printing which HandlerPool +hpId_ :: HandlerPool -> IO String hpId_ (HandlerPool cnt bag) = do sn1 <- makeStableName cnt sn2 <- makeStableName bag @@ -682,26 +750,24 @@ return $ show (hashStableName sn1) ++"/"++ show (hashStableName sn2) ++ " transient cnt "++show c +-- | For debugging purposes. This can help us figure out (by an ugly +-- process of elimination) which MVar reads are leading to a "Thread +-- blocked indefinitely" exception. +{- +busyTakeMVar :: String -> MVar a -> IO a +busyTakeMVar msg mv = try (10 * 1000 * 1000) + where + try 0 = do + when dbg $ do + tid <- myThreadId + -- After we've failed enough times, start complaining: + printf "%s not getting anywhere, msg: %s\n" (show tid) msg + try (100 * 1000) + try n = do + x <- tryTakeMVar mv + case x of + Just y -> return y + Nothing -> do yield; try (n-1) +-} --- | Exceptions that walk up the fork tree of threads. -forkWithExceptions :: (IO () -> IO ThreadId) -> String -> IO () -> IO ThreadId -forkWithExceptions forkit descr action = do - parent <- myThreadId - forkit $ do - tid <- myThreadId - E.catch action - (\ e -> - case E.fromException e of - Just E.ThreadKilled -> do --- Killing worker threads is normal now when exception handling, so this chatter is restricted to debug mode: -#ifdef DEBUG_LVAR - printf "\nThreadKilled exception inside child thread, %s (not propagating!): %s\n" (show tid) (show descr) -#endif - return () - _ -> do -#ifdef DEBUG_LVAR - printf "\nException inside child thread %s, %s: %s\n" (show descr) (show tid) (show e) -#endif - E.throwTo parent (e :: E.SomeException) - ) diff --git a/Control/LVish/SchedIdempotentInternal.hs b/Control/LVish/SchedIdempotentInternal.hs --- a/Control/LVish/SchedIdempotentInternal.hs +++ b/Control/LVish/SchedIdempotentInternal.hs @@ -4,7 +4,8 @@ {-# LANGUAGE RecursiveDo #-} module Control.LVish.SchedIdempotentInternal ( - State(), new, number, next, pushWork, yieldWork, currentCPU, setStatus, await, prng + State(logger, no), initLogger, + new, number, next, pushWork, nullQ, yieldWork, currentCPU, setStatus, await, prng ) where @@ -16,7 +17,11 @@ import Data.IORef import GHC.Conc import System.Random (StdGen, mkStdGen) +import System.IO (stdout) +import Text.Printf +import qualified Control.LVish.Logging as L + #ifdef CHASE_LEV #warning "Compiling with Chase-Lev work-stealing deque" @@ -28,9 +33,10 @@ popMine = CL.tryPopL popOther = CL.tryPopR pushYield = pushMine -- for now... +nullQ = CL.nullQ #else - +#warning "Compiling with non-scalable deque." ------------------------------------------------------------------------------ -- A nonscalable deque for work-stealing ------------------------------------------------------------------------------ @@ -54,6 +60,12 @@ [] -> ([], Nothing) (t:ts') -> (ts', Just t) +nullQ :: Deque a -> IO Bool +nullQ deque = do + ls <- readIORef deque + return $! null ls + + -- | Add low-priority work to a thread's own work deque pushYield :: Deque a -> a -> IO () pushYield deque t = @@ -71,12 +83,17 @@ -- All the state relevant to a single worker thread data State a s = State - { no :: {-# UNPACK #-} !Int, - prng :: IORef StdGen, -- core-local random number generation - status :: IORef s, - workpool :: Deque a, - idle :: IORef [MVar Bool], -- global list of idle workers - states :: [State a s] -- global list of all worker states. + { no :: {-# UNPACK #-} !Int, -- ^ The number of this worker + numWorkers :: Int, -- ^ Total number of workers in this runPar + prng :: IORef StdGen, -- ^ core-local random number generation + status :: IORef s, -- ^ A thread-local flag + workpool :: Deque a, -- ^ The thread-local work deque + idle :: IORef [MVar Bool], -- ^ global list of idle workers + states :: [State a s], -- ^ global list of all worker states. + logger :: IORef (Maybe L.Logger) + -- ^ The Logger object used by the current Par session. (This should not + -- change during runtime, it is mutable only to support deferred + -- initialization.) } -- | Process the next item on the work queue or, failing that, go into @@ -93,27 +110,33 @@ -- Cilk time/space bounds if one is running strictly nested (series -- parallel) programs. --- | Attempt to steal work or, failing that, give up and go idle. +-- | Attempt to steal work or, failing that, give up and go idle (and then wake back +-- up and keep stealing). +-- +-- This function does NOT return until the complete runPar session is complete (all +-- workers idle). steal :: State a s -> IO (Maybe a) -steal State{ idle, states, no=my_no } = do - -- printf "cpu %d stealing\n" my_no +steal State{ idle, states, no=my_no, numWorkers } = do + chatter $ printf "!cpu %d stealing\n" my_no go states where + -- After a failed sweep, go idle: go [] = do m <- newEmptyMVar r <- atomicModifyIORef idle $ \is -> (m:is, is) - if length r == numCapabilities - 1 + if length r == numWorkers - 1 then do - -- printf "cpu %d initiating shutdown\n" my_no + chatter$ printf "!cpu %d initiating shutdown\n" my_no mapM_ (\m -> putMVar m True) r return Nothing else do + chatter $ printf "!cpu %d going idle...\n" my_no done <- takeMVar m if done then do - -- printf "cpu %d shutting down\n" my_no + chatter $ printf "!cpu %d shutting down\n" my_no return Nothing else do - -- printf "cpu %d woken up\n" my_no + chatter $ printf "!cpu %d woken up\n" my_no go states go (x:xs) | no x == my_no = go xs @@ -127,6 +150,8 @@ -- | If any worker is idle, wake one up and give it work to do. pushWork :: State a s -> a -> IO () +-- TODO: If we're really going to do wakeup on every push we could consider giving +-- the formerly-idle worker the work item directly and thus avoid touching the deque. pushWork State { workpool, idle } t = do pushMine workpool t idles <- readIORef idle @@ -140,28 +165,64 @@ yieldWork State { workpool } t = pushYield workpool t -- AJT: should this also wake an idle thread? +-- | Create a new set of scheduler states. new :: Int -> s -> IO [State a s] -new n s = do - idle <- newIORef [] +new numWorkers s = do + idle <- newIORef [] + logger <- newIORef Nothing let mkState states i = do workpool <- newDeque status <- newIORef s prng <- newIORef $ mkStdGen i - return State { no = i, workpool, idle, status, states, prng } - rec states <- forM [0..(n-1)] $ mkState states + return State { no = i, workpool, idle, status, states, prng, logger, numWorkers } + rec states <- forM [0..(numWorkers-1)] $ mkState states return states +-- | Takes a full set of worker states and correspoding threadIds and initializes the +-- loggers. +initLogger :: [State a s] -> [ThreadId] -> (Int,Int) -> [L.OutDest] -> Bool -> IO () +initLogger [] _ _ _ _ = error "initLogger: cannot take empty list of workers" +initLogger queues@(hd:_) tids bounds outDests debugScheduling + | len1 /= len2 = error "initLogger: length of arguments did not match" + | otherwise = do + lgr <- L.newLogger bounds outDests + (if debugScheduling then waitAll else L.DontWait) + -- lgr <- L.newLogger Nothing (L.WaitNum len1 countIdle) + L.logOn lgr (L.StrMsg 1 " [dbg-lvish] Initializing Logger... ") + -- Setting one of them sets all of them -- this field is shared: + writeIORef (logger hd) (Just lgr) + -- TODO: ASSERT that they are all actually the same IORef? + return () + where + waitAll = (L.WaitTids tids (pollDeques queues)) + + len1 = length queues + len2 = length tids + countIdle = do ls <- readIORef (idle hd) + return $! length ls + pollDeques [] = return True + pollDeques (h:t) = do b <- nullQ (workpool h) + if b then pollDeques t + else return False + number :: State a s -> Int number State { no } = no setStatus :: State a s -> s -> IO () setStatus State { status } s = writeIORef status s +-- This is a hard-spinning busy-wait. await :: State a s -> (s -> Bool) -> IO () -await State { states } p = - let awaitOne state@(State { status }) = do +await State { states, logger, no=no1 } p = + let awaitOne state@(State { status, no=no2 }) = do cur <- readIORef status - unless (p cur) $ awaitOne state + unless (p cur) $ do + mlgr <- readIORef logger + case mlgr of + Nothing -> return () + Just lgr -> L.logOn lgr (L.StrMsg 7 (" [dbg-lvish] busy-waiting on worker "++show no1++ + ", for status to change on worker "++show no2)) + awaitOne state in mapM_ awaitOne states -- | the CPU executing the current thread (0 if not supported) @@ -185,3 +246,8 @@ -- return 0 #endif + + +chatter :: String -> IO () +-- chatter s = putStrLn s +chatter _ = return () diff --git a/Control/LVish/Types.hs b/Control/LVish/Types.hs --- a/Control/LVish/Types.hs +++ b/Control/LVish/Types.hs @@ -2,11 +2,14 @@ -- | A simple internal module to factor out types that are used in many places. module Control.LVish.Types - (LVishException(..)) - where + ( LVishException(..) + , OutDest (..) + , DbgCfg(..)) + where import Data.Typeable (Typeable) import Control.Exception +import System.IO (Handle) -- | All @LVar@s share a common notion of exceptions. -- The two common forms of exception currently are conflicting-put and put-after-freeze. @@ -18,3 +21,20 @@ instance Exception LVishException +-- | A destination for log messages +data OutDest = -- NoOutput -- ^ Drop them entirely. + OutputEvents -- ^ Output via GHC's `traceEvent` runtime events. + | OutputTo Handle -- ^ Printed human-readable output to a handle. + | OutputInMemory -- ^ Accumulate output in memory and flush when appropriate. + +-- DebugConfig +data DbgCfg = + DbgCfg { dbgRange :: Maybe (Int,Int) + -- ^ Inclusive range of debug messages to accept + -- (i.e. filter on priority level). If Nothing, use the default level, + -- which is (0,N) where N is controlled by the DEBUG environment variable. + , dbgDests :: [OutDest] -- ^ Destinations for debug log messages. + , dbgScheduling :: Bool + -- ^ In additional to logging debug messages, control + -- thread interleaving at these points when this is True. + } diff --git a/Control/LVish/Unsafe.hs b/Control/LVish/Unsafe.hs new file mode 100644 --- /dev/null +++ b/Control/LVish/Unsafe.hs @@ -0,0 +1,13 @@ + +-- | For debugging purposes, it can be useful to lift an IO computation into an LVish @Par@ monad. +-- +-- This module is imported for instances only (specifically, the `MonadIO` instance). + +module Control.LVish.Unsafe() where + +import Control.LVish.Internal +import Control.Monad.IO.Class +import qualified Control.LVish.SchedIdempotent as L + +instance MonadIO (Par d s) where + liftIO = WrapPar . L.liftIO diff --git a/Data/Concurrent/Bag.hs b/Data/Concurrent/Bag.hs --- a/Data/Concurrent/Bag.hs +++ b/Data/Concurrent/Bag.hs @@ -4,7 +4,7 @@ import Control.Concurrent import System.IO.Unsafe (unsafePerformIO) import Data.IORef -import qualified Data.Map as M +import qualified Data.IntMap as M ------------------------------------------------------------------------------ -- A nonscalable implementation of a concurrent bag @@ -12,12 +12,13 @@ type UID = Int type Token a = (Bag a, UID) -type Bag a = IORef (M.Map UID a) +type Bag a = IORef (M.IntMap a) -- Return the old value. Could replace with a true atomic op. atomicIncr :: IORef Int -> IO Int atomicIncr cntr = atomicModifyIORef' cntr (\c -> (c+1,c)) +{-# NOINLINE uidCntr #-} uidCntr :: IORef UID uidCntr = unsafePerformIO (newIORef 0) diff --git a/Data/Concurrent/Counter.hs b/Data/Concurrent/Counter.hs --- a/Data/Concurrent/Counter.hs +++ b/Data/Concurrent/Counter.hs @@ -1,3 +1,5 @@ +-- | A simple, non-scalable counter. + module Data.Concurrent.Counter(Counter, new, inc, dec, poll) where import Control.Monad @@ -9,6 +11,7 @@ new :: IO Counter new = newIORef 0 +-- TODO: at least switch to use fetch-and-add... inc :: Counter -> IO () inc c = atomicModifyIORef' c $ \n -> (n+1,()) diff --git a/Data/Concurrent/LinkedMap.hs b/Data/Concurrent/LinkedMap.hs --- a/Data/Concurrent/LinkedMap.hs +++ b/Data/Concurrent/LinkedMap.hs @@ -1,4 +1,5 @@ {-# LANGUAGE NamedFieldPuns, BangPatterns #-} +{-# LANGUAGE RankNTypes #-} -- | A concurrent finite map represented as a single linked list. -- @@ -16,8 +17,13 @@ -- data structures, e.g. SkipListMap. module Data.Concurrent.LinkedMap ( - LMap(), newLMap, Token(), value, find, FindResult(..), tryInsert, - foldlWithKey, map, reverse) + LMap(), LMList(..), + newLMap, Token(), value, find, FindResult(..), tryInsert, + foldlWithKey, map, reverse, head, toList, fromList, findIndex, + + -- * Utilities for splitting/slicing + halve, halve', dropUntil + ) where import Data.IORef @@ -25,7 +31,8 @@ import Control.Reagent -- AT: not yet using this, but would be nice to refactor -- to use it. import Control.Monad.IO.Class -import Prelude hiding (reverse, map) +import Control.Exception (assert) +import Prelude hiding (reverse, map, head) -- | A concurrent finite map, represented as a linked list data LMList k v = @@ -81,14 +88,17 @@ -- | Concurrently fold over all key/value pairs in the map within the given -- monad, in increasing key order. Inserts that arrive concurrently may or may -- not be included in the fold. -foldlWithKey :: MonadIO m => (a -> k -> v -> m a) -> a -> LMap k v -> m a -foldlWithKey f a m = do - n <- liftIO $ readIORef m +-- +-- Strict in the accumulator. +foldlWithKey :: Monad m => (forall x . IO x -> m x) -> + (a -> k -> v -> m a) -> a -> LMap k v -> m a +foldlWithKey liftIO f !a !m = do + n <- liftIO$ readIORef m case n of Empty -> return a Node k v next -> do a' <- f a k v - foldlWithKey f a' next + foldlWithKey liftIO f a' next -- | Map over a snapshot of the list. Inserts that arrive concurrently may or may @@ -96,7 +106,8 @@ -- same. map :: MonadIO m => (a -> b) -> LMap k a -> m (LMap k b) map fn mp = do - tmp <- foldlWithKey (\ acc k v -> do + tmp <- foldlWithKey liftIO + (\ acc k v -> do r <- liftIO (newIORef acc) return$! Node k (fn v) r) Empty mp @@ -115,3 +126,93 @@ Node k v next -> do r <- liftIO (newIORef acc) loop (Node k v r) next + +head :: LMap k v -> IO (Maybe k) +head lm = do + x <- readIORef lm + case x of + Empty -> return Nothing + Node k _ _ -> return $! Just k + +-- | Convert to a list +toList :: LMap k v -> IO [(k,v)] +toList lm = do + x <- readIORef lm + case x of + Empty -> return [] + Node k v tl -> do + ls <- toList tl + return $! (k,v) : ls + +-- | Convert from a list. +fromList :: [(k,v)] -> IO (LMap k v) +fromList ls = do + let loop [] = return Empty + loop ((k,v):tl) = do + tl' <- loop tl + ref <- newIORef tl' + return $! Node k v ref + lm <- loop ls + newIORef lm + + +halve' :: Ord k => Maybe k -> LMap k v -> IO (Maybe (LMap k v, LMap k v)) +halve' mend lm = do + lml <- readIORef lm + res <- halve mend lml + case res of + Nothing -> return Nothing + Just (len1,_len2,tailhd) -> do + ls <- toList lm + l' <- fromList (take len1 ls) + r' <- newIORef tailhd + return $! Just $! (l',r') + + +-- | Attempt to split into two halves. +-- +-- This optionally takes an upper bound key, which is treated as an alternate +-- end-of-list signifier. +-- +-- Result: If there is only one element, then return Nothing. If there are more, +-- return the number of elements in the first and second halves, plus a pointer to +-- the beginning of the second half. It is a contract of this function that the +-- two Ints returned are non-zero. +-- +halve :: Ord k => Maybe k -> LMList k v -> IO (Maybe (Int, Int, LMList k v)) +{-# INLINE halve #-} +halve mend ls = loop 0 ls ls + where + isEnd Empty = True + isEnd (Node k _ _) = + case mend of + Just end -> k >= end + Nothing -> False + emptCheck (0,l2,t) = return Nothing + emptCheck !x = return $! Just x + + loop len tort hare | isEnd hare = + emptCheck (len, len, tort) + loop len tort@(Node _ _ next1) (Node k v next2) = do + next2' <- readIORef next2 + case next2' of + x | isEnd x -> emptCheck (len, len+1, tort) + Node _ _ next3 -> do next1' <- readIORef next1 + next3' <- readIORef next3 + loop (len+1) next1' next3' + +-- | Drop from the front of the list until the first key is equal or greater than the +-- given key. +dropUntil :: Ord k => k -> LMList k v -> IO (LMList k v) +dropUntil _ Empty = return Empty +dropUntil stop nd@(Node k v tl) + | stop <= k = return nd + | otherwise = do tl' <- readIORef tl + dropUntil stop tl' + +-- | Given a pointer into the middle of the list, find how deep it is. +-- findIndex :: Eq k => LMList k v -> LMList k v -> IO (Maybe Int) +findIndex :: Eq k => LMList k v -> LMList k v -> IO (Maybe Int) +findIndex ls1 ls2 = + error "FINISHME - LinkedMap.findIndex" + diff --git a/Data/Concurrent/SkipListMap.hs b/Data/Concurrent/SkipListMap.hs --- a/Data/Concurrent/SkipListMap.hs +++ b/Data/Concurrent/SkipListMap.hs @@ -1,4 +1,9 @@ {-# LANGUAGE ExistentialQuantification, GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ParallelListComp #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} -- for debugging -- | An implementation of concurrent finite maps based on skip lists. Only -- supports lookup and insertions, not modifications or removals. @@ -20,8 +25,12 @@ -- each of which has a different type (since it indexes the layer below it). module Data.Concurrent.SkipListMap ( - SLMap(), newSLMap, find, PutResult(..), putIfAbsent, putIfAbsentToss, foldlWithKey, counts + SLMap(), newSLMap, find, PutResult(..), putIfAbsent, putIfAbsentToss, foldlWithKey, counts, -- map: is not exposed, because it has that FINISHME for now... [2013.10.01] + debugShow, + + -- * Slicing SLMaps + SLMapSlice(Slice), toSlice, splitSlice, sliceSize ) where @@ -30,25 +39,38 @@ import Control.Applicative ((<$>)) import Control.Monad import Control.Monad.IO.Class +import Control.Exception (assert) import Control.LVish.MonadToss import Control.LVish (Par) - + +import Control.LVish.Unsafe () -- FOR MonadIO INSTANCE! FIXME. We can't keep this from escaping. +import Data.Maybe (fromMaybe) import Data.IORef import Data.Atomics import qualified Data.Concurrent.LinkedMap as LM import Prelude hiding (map) +import qualified Prelude as P -- | The GADT representation. The type @t@ gives the type of nodes at a given -- level in the skip list. data SLMap_ k v t where - Bottom :: LM.LMap k v -> SLMap_ k v (LM.LMap k v) + Bottom :: LM.LMap k v -> SLMap_ k v (LM.LMap k v) Index :: LM.LMap k (t, v) -> SLMap_ k v t -> SLMap_ k v (LM.LMap k (t, v)) -- The complete multi-level SLMap always keeps a pointer to the bottom level (the -- second field). data SLMap k v = forall t. SLMap (SLMap_ k v t) (LM.LMap k v) +-- | A portion of an SLMap between two keys. If the upper-bound is missing, that +-- means "go to the end". The optional lower bound is used to "lazily" prune the +-- fronts each layer. The reason for this is that we don't want to reallocate an +-- IORef spine and prematurely prune all lower layers IF we're simply going to +-- split again before actually enumerating the contents. +data SLMapSlice k v = Slice (SLMap k v) + !(Maybe k) -- Lower bound. + !(Maybe k) -- Upper bound. + -- | Physical identity instance Eq (SLMap k v) where SLMap _ lm1 == SLMap _ lm2 = lm1 == lm2 @@ -72,7 +94,7 @@ -- At the bottom level: just lift the find from LinkedMap find_ (Bottom m) shortcut k = do - searchResult <- LM.find (maybe m id shortcut) k + searchResult <- LM.find (fromMaybe m shortcut) k case searchResult of LM.Found v -> return $ Just v LM.NotFound tok -> return Nothing @@ -80,7 +102,7 @@ -- At an indexing level: attempt to use the index to shortcut into the level -- below. find_ (Index m slm) shortcut k = do - searchResult <- LM.find (maybe m id shortcut) k + searchResult <- LM.find (fromMaybe m shortcut) k case searchResult of LM.Found (_, v) -> return $ Just v -- the key is in the index itself; we're outta here @@ -136,7 +158,7 @@ putIfAbsent_ (Bottom m) shortcut k vc coin install = retryLoop vc where -- The retry loop; ensures that vc is only executed once retryLoop vc = do - searchResult <- liftIO $ LM.find (maybe m id shortcut) k + searchResult <- liftIO $ LM.find (fromMaybe m shortcut) k case searchResult of LM.Found v -> return $ Found v LM.NotFound tok -> do @@ -151,7 +173,7 @@ -- At an index level; try to shortcut into the level below, while remembering -- where we were so that we can insert index nodes later on putIfAbsent_ (Index m slm) shortcut k vc coin install = do - searchResult <- liftIO $ LM.find (maybe m id shortcut) k + searchResult <- liftIO $ LM.find (fromMaybe m shortcut) k case searchResult of LM.Found (_, v) -> return $ Found v -- key is in the index; bail out LM.NotFound tok -> @@ -171,8 +193,11 @@ -- | Concurrently fold over all key/value pairs in the map within the given -- monad, in increasing key order. Inserts that arrive concurrently may or may -- not be included in the fold. -foldlWithKey :: MonadIO m => (a -> k -> v -> m a) -> a -> SLMap k v -> m a -foldlWithKey f a (SLMap _ lm) = LM.foldlWithKey f a lm +-- +-- Strict in the accumulator. +foldlWithKey :: Monad m => (forall x . IO x -> m x) -> + (a -> k -> v -> m a) -> a -> SLMap k v -> m a +foldlWithKey liftIO f !a (SLMap _ !lm) = LM.foldlWithKey liftIO f a lm -- | Create an identical copy of an (unchanging) SLMap with the keys unchanged and -- the values replaced by the result of applying the provided function. @@ -195,9 +220,152 @@ counts_ :: SLMap_ k v t -> IO [Int] counts_ (Bottom m) = do - c <- LM.foldlWithKey (\n _ _ -> return (n+1)) 0 m + c <- LM.foldlWithKey id (\n _ _ -> return (n+1)) 0 m return [c] counts_ (Index m slm) = do - c <- LM.foldlWithKey (\n _ _ -> return (n+1)) 0 m + c <- LM.foldlWithKey id (\n _ _ -> return (n+1)) 0 m cs <- counts_ slm return $ c:cs + + +-- | Create a slice corresponding to the entire (non-empty) map. +toSlice :: SLMap k v -> SLMapSlice k v +toSlice mp = Slice mp Nothing Nothing + + +instance Show (LM.LMap k v) where + show _ = "" + +instance Show (LM.LMList k v) where + show _ = "" + +-- | Attempt to split a slice of an SLMap. If there are not enough elements to form +-- two slices, this retruns Nothing. +splitSlice :: forall k v . (Show k, Ord k) => + SLMapSlice k v -> IO (Maybe (SLMapSlice k v, SLMapSlice k v)) +splitSlice sl0@(Slice (SLMap index lmbot) mstart mend) = do + res <- loop index + case res of + Just (x,y) -> do sz1 <- fmap (P.map fst) $ sliceToList sl0 + sz2 <- fmap (P.map fst) $ sliceToList x + sz3 <- fmap (P.map fst) $ sliceToList y + putStrLn $ "Splitslice! size " ++(show sz1) ++" out szs "++(show (sz2,sz3)) + ++ " mstart/end "++show (mstart,mend) + Nothing -> return () + return res + where + loop :: SLMap_ k v t -> IO (Maybe (SLMapSlice k v, SLMapSlice k v)) + loop (Bottom lm) = do + putStrLn "AT BOT" + lm' <- readIORef lm + lm'' <- case mstart of + Nothing -> return lm' + Just strtK -> LM.dropUntil strtK lm' + res <- LM.halve mend lm'' + + -- DEBUG: + putStrLn $ "halve RES -> "++show res + + case res of + Nothing -> return Nothing + Just x -> dosplit (SLMap (Bottom lm) lm) + (\ tlboxed -> SLMap (Bottom tlboxed) tlboxed) x + + loop orig@(Index m slm) = do + indm <- readIORef m + indm' <- case mstart of + Nothing -> return indm + Just strtK -> LM.dropUntil strtK indm + -- Halve *this* level of the index, and use that as a fast way to split everything below. + res <- LM.halve mend indm' + case res of + -- Case 1: This level isn't big enough to split, keep going down. Note that we don't + -- reconstruct the higher level, for splitting we don't care about it: + Nothing -> loop slm + -- Case 2: Do the split but use the full lmbot on the right + -- (lazy pruning of the head elements): + Just x -> dosplit (SLMap orig lmbot) + (\ tlboxed -> SLMap (Index tlboxed slm) lmbot) x + + -- Create the left and right slices when halving is successful. + dosplit :: SLMap k v -> (LM.LMap k tmp -> SLMap k v) -> + (Int, Int, LM.LMList k tmp) -> + IO (Maybe (SLMapSlice k v, SLMapSlice k v)) + dosplit lmap mkRight (lenL, lenR, tlseg) = + assert (lenL > 0) $ assert (lenR > 0) $ do + putStrLn $ "Halved lengths "++show (lenL,lenR) + -- We don't really want to allocate just for slicing... but alas we need new + -- IORef boxes here. We lazily prune the head of the lower levels, but we + -- don't want to throw away the work we've done traversing to this point in "loop": + tlboxed <- newIORef tlseg + tmp <- fmap length $ LM.toList tlboxed + let (LM.Node tlhead _ _) = tlseg + rmap = mkRight tlboxed + rslice = Slice rmap (Just tlhead) mend + lslice = Slice lmap Nothing (Just tlhead) + return $! Just $! (lslice, rslice) + + +-- | /O(N)/ measure the length of the bottom tier. +sliceSize :: Ord k => SLMapSlice k v -> IO Int +sliceSize slc = do + ls <- sliceToList slc + return $! length ls + +sliceToList :: Ord k => SLMapSlice k v -> IO [(k,v)] +sliceToList (Slice (SLMap _ lmbot) mstart mend) = do + ls <- LM.toList lmbot + -- We SHOULD use the index layers to shortcut to a start, then stop at the end. + return $! [ pr | pr@(k,v) <- ls, strtCheck k, endCheck k ] -- Inefficient! + where + strtCheck = case mstart of + Just strt -> \ k -> k >= strt + Nothing -> \ _ -> True + endCheck = case mend of + Just end -> \ k -> k < end + Nothing -> \ _ -> True + + + +-- | Print a slice with each layer on a line. +debugShow :: forall k v . (Ord k, Show k, Show v) => SLMapSlice k v -> IO String +debugShow (Slice (SLMap index lmbot) mstart mend) = + do lns <- loop index + let len = length lns + return $ unlines [ "["++show i++"] "++l | l <- lns | i <- reverse [0..len-1] ] + where + startCheck = case mstart of + Just start -> \ k -> k >= start + Nothing -> \ _ -> True + endCheck = case mend of + Just end -> \ k -> k < end + Nothing -> \ _ -> True + + loop :: SLMap_ k v t -> IO [String] + loop (Bottom lm) = do + ls <- LM.toList lm + return [ unwords $ [ if endCheck k && startCheck k + then show i++":"++show k++","++show v + else "_" + | i <- [0::Int ..] + | (k,v) <- ls +-- , startCheck k + ] ] + loop (Index indm slm) = do + ls <- LM.toList indm + strs <- forM [ (i,tup) | i <- [0..] | tup@(k,_) <- ls ] $ -- , startCheck k + \ (ix, (key, (shortcut::t, val))) -> do + -- Peek at the next layer down: +{- + case (slm::SLMap_ k v t) of + Index (nxt::LM.LMap k (t2,v)) _ -> do +-- Could not deduce (t3 ~ IORef (LM.LMList k (t3, v))) + lmlst <- readIORef nxt + LM.findIndex lmlst lmlst +-- Bottom x -> x +-} + if endCheck key && startCheck key + then return $ show ix++":"++show key++","++show val + else return "_" + rest <- loop slm + return $ unwords strs : rest diff --git a/Data/LVar/AddRemoveSet.hs b/Data/LVar/AddRemoveSet.hs new file mode 100644 --- /dev/null +++ b/Data/LVar/AddRemoveSet.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE BangPatterns #-} + +{-| + +This module provides sets that allow both addition and removal of +elements. This is possible because, under the hood, it's represented +with two monotonically growing sets, one for additions and one for +removals. It is inspired by /2P-Sets/ from the literature on +/conflict-free replicated data types/. + + -} +module Data.LVar.AddRemoveSet + ( + AddRemoveSet, + newEmptySet, newSet, newFromList, + insert, waitAddedElem, waitAddedSize, + remove, waitRemovedElem, waitRemovedSize, + + freezeSet + + ) where +import qualified Data.Set as S +import Control.LVish +import Control.LVish.Internal +import qualified Data.LVar.PureSet as PS +import Control.Applicative + +-- | The set datatype. +data AddRemoveSet s a = + AddRemoveSet !(PS.ISet s a) + !(PS.ISet s a) + +-- | Create a new, empty `AddRemoveSet`. +newEmptySet :: Ord a => Par d s (AddRemoveSet s a) +newEmptySet = newSet S.empty + +-- | Create a new `AddRemoveSet` populated with initial elements. +newSet :: Ord a => S.Set a -> Par d s (AddRemoveSet s a) +-- Here we're creating two new PureSets, one from the provided initial +-- elements (the "add" set) and one empty (the "remove" set), and +-- then, since both of those return `Par` computations, we're using +-- our friends `<$>` and `<*>`. +newSet set = AddRemoveSet <$> (PS.newSet set) <*> PS.newEmptySet +-- Alternate version that works if we import `Control.Monad`: +-- newSet set = ap (fmap AddRemoveSet (PS.newSet set)) PS.newEmptySet + +-- | A simple convenience function. Create a new 'ISet' drawing +-- initial elements from an existing list. +newFromList :: Ord a => [a] -> Par d s (AddRemoveSet s a) +newFromList ls = newSet (S.fromList ls) + +-- | Put a single element in the set. (WHNF) Strict in the element +-- being put in the set. +insert :: Ord a => a -> AddRemoveSet s a -> Par d s () +-- Because the two sets inside an AddRemoveSet are already PureSets, +-- we really just have to call the provided `insert` method for +-- PureSet. We don't need to call `putLV` or anything like that! +insert !elm (AddRemoveSet added removed) = PS.insert elm added + +-- | Wait for the set to contain a specified element. +waitAddedElem :: Ord a => a -> AddRemoveSet s a -> Par d s () +-- And similarly here, we don't have to call `getLV` ourselves. +waitAddedElem !elm (AddRemoveSet added removed) = PS.waitElem elm added + +-- | Wait on the size of the set of added elements. +waitAddedSize :: Int -> AddRemoveSet s a -> Par d s () +-- You get the idea... +waitAddedSize !sz (AddRemoveSet added removed) = PS.waitSize sz added + +-- | Remove a single element from the set. +remove :: Ord a => a -> AddRemoveSet s a -> Par d s () +-- We remove an element by adding it to the `removed` set! +remove !elm (AddRemoveSet added removed) = PS.insert elm removed + +-- | Wait for a single element to be removed from the set. +waitRemovedElem :: Ord a => a -> AddRemoveSet s a -> Par d s () +waitRemovedElem !elm (AddRemoveSet added removed) = PS.waitElem elm removed + +-- | Wait on the size of the set of removed elements. +waitRemovedSize :: Int -> AddRemoveSet s a -> Par d s () +waitRemovedSize !sz (AddRemoveSet added removed) = PS.waitSize sz removed + +-- | Get the exact contents of the set. As with any +-- quasi-deterministic operation, using `freezeSet` may cause your +-- program to exhibit a limited form of nondeterminism: it will never +-- return the wrong answer, but it may include synchronization bugs +-- that can (nondeterministically) cause exceptions. +freezeSet :: Ord a => AddRemoveSet s a -> QPar s (S.Set a) +-- Freezing takes the set difference of added and removed elements. +freezeSet (AddRemoveSet added removed) = + liftA2 S.difference (PS.freezeSet added) (PS.freezeSet removed) diff --git a/Data/LVar/CycGraph.hs b/Data/LVar/CycGraph.hs new file mode 100644 --- /dev/null +++ b/Data/LVar/CycGraph.hs @@ -0,0 +1,576 @@ +{-# LANGUAGE ScopedTypeVariables, DataKinds #-} +{-# LANGUAGE KindSignatures, EmptyDataDecls #-} +{-# LANGUAGE NamedFieldPuns, ParallelListComp #-} +{-# LANGUAGE BangPatterns, CPP #-} +{-# LANGUAGE FlexibleInstances #-} +-- {-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -O2 #-} + +{-| + +In contrast with "Data.LVar.Memo", this module provides a way to run a computation +for each node of a graph WITH support for cycles. Cycles are explicitly recognized +and then may be handled in an application specific fashion. + + -} + +module Data.LVar.CycGraph + ( + -- * An idiom for fixed point computations + exploreGraph_seq, + Response(..), + + -- * A parallel version + exploreGraph, NodeValue(..), NodeAction, + + -- * Debugging aides + ShortShow(..), shortTwo + ) + where +-- Standard: +import Data.Set (Set) +import Control.Monad +import qualified Data.Set as S +import qualified Data.Map as M +import Data.IORef +import Data.Char (ord) +import Data.List (intersperse) +import Data.Int +import qualified Data.Foldable as F +import System.IO.Unsafe +import Debug.Trace + +-- LVish: +import Control.LVish +import qualified Control.LVish.Internal as LV +import qualified Control.LVish.SchedIdempotent as LI +import Data.LVar.PureSet as IS +import Data.LVar.IVar as IV +import qualified Data.Concurrent.SkipListMap as SLM +import qualified Data.Set as S +import qualified Data.LVar.PureMap as IM +-- import qualified Data.LVar.SLMap as IM +-- import qualified Data.LVar.PureSet as S + +----- For debugging: ---- +#ifdef DEBUG_MEMO +import System.Environment (getEnvironment) +import Data.Graph.Inductive.Graph as G +import Data.Graph.Inductive.PatriciaTree as G +import Data.GraphViz as GV +import qualified Data.GraphViz.Attributes.Complete as GA +import qualified Data.GraphViz.Attributes.Colors as GC +import Data.Text.Lazy (pack) +#endif +-------------------------------------------------------------------------------- +-- Simple atomic Set accumulators +-------------------------------------------------------------------------------- + +-- | Could use a more scalable structure here... but we need union as well as +-- elementwise insertion. +type SetAcc a = IORef (S.Set a) + +-- Here @SetAcc@s are LINKED to downstream SetAcc's which must receive all the same +-- inserts that they do. +-- newtype SetAcc a = SetAcc (IORef (S.Set a, [SetAcc a])) + +newSetAcc :: Par d s (SetAcc a) +newSetAcc = LV.WrapPar $ LI.liftIO $ newIORef S.empty +readSetAcc :: (SetAcc a) -> Par d s (S.Set a) +readSetAcc r = LV.WrapPar $ LI.liftIO $ readIORef r +insertSetAcc :: Ord a => a -> SetAcc a -> Par d s (S.Set a) +insertSetAcc x ref = LV.WrapPar $ LI.liftIO $ + atomicModifyIORef' ref (\ s -> let ss = S.insert x s in (ss,ss)) +unionSetAcc :: Ord a => Set a -> SetAcc a -> Par d s (S.Set a) +unionSetAcc x ref = LV.WrapPar $ LI.liftIO $ + atomicModifyIORef' ref (\ s -> let ss = S.union x s in (ss,ss)) + +-------------------------------------------------------------------------------- +-- Types +-------------------------------------------------------------------------------- + +-- | A Memo-table that stores cached results of executing a `Par` computation. +-- +-- This, enhanced, version of the Memo-table also is required to track all the keys +-- that are reachable from each key (for cycle-detection). +data Memo (d::Determinism) s k v = + -- Here we keep both a Ivars of return values, and a set of keys whose computations + -- have traversed through THIS key. If we see a cycle there, we can catch it. +-- !(IM.IMap k s (SetAcc k, IVar s v)) + + Memo !(IS.ISet s k) + -- EXPENSIVE version: + !(IM.IMap k s (NodeRecord s k v)) + -- ^ Store all the keys that we know *can reach this key* + +-- | All the information associated with one node in the graph of keys. +data NodeRecord s k v = NodeRecord + { mykey :: k + , chldrn :: [k] + , reachme :: !(IS.ISet s k) -- ^ Which keys are upstream of me in the graph + , in_cycle :: !(IVar s Bool) -- ^ Does this node participate in any cycle? + , result :: !(IVar s v) -- ^ The result of the per-node computation. + } deriving (Eq) + +-------------------------------------------------------------------------------- +-- Cycle-detecting mapping of a computation over graph neighborhoods +-------------------------------------------------------------------------------- + +-- | A means of building a dynamic graph. The node computation returns a response +-- which may either be a final value, or a request to explore more nodes (together +-- with a continuation for the resulting value). +-- +-- Note that because only one key is requested at a time, this cannot express +-- parallel graph traversals. +data Response par key ans = + Done !ans + | Request !key (RequestCont par key ans) + +type RequestCont par key ans = (ans -> par (Response par key ans)) + +-------------------------------------------------------------------------------- +-- Sequential version: + +-- | This supercombinator does a parallel depth-first search of a dynamic graph, with +-- detection of cycles. +-- +-- Each node in the graph is a computation whose input is the `key` (the vertex ID). +-- Each such computation dynamically computes which other keys it depends on and +-- requests the values associated with those keys. +-- +-- This implementation uses a sequential depth-first-search (DFS), starting from the +-- initially requested key. One can picture this search as a directed tree radiating +-- from the starting key. When a cycle is detected at any leaf of this tree, an +-- alternate cycle handler is called instead of running the normal computation for +-- that key. +exploreGraph_seq :: forall d s k v . (Ord k, Eq v, Show k, Show v) => + (k -> Par d s (Response (Par d s) k v)) -- ^ The computation to perform for new requests + -> (k -> Par d s v) -- ^ Handler for a cycle on @k@. The + -- value it returns is in lieu of running + -- the main computation at this + -- particular node in the graph. + -> k -- ^ Key to lookup. + -> Par d s v +exploreGraph_seq initCont cycHndlr initKey = do + -- Start things off: + resp <- initCont initKey + v <- loop initKey (S.singleton initKey) resp return + return v + where + loop :: k -> S.Set k -> (Response (Par d s) k v) -> (v -> Par d s v) -> Par d s v + loop current hist resp kont = do + dbgPr (" [MemoFixedPoint] going around loop, key "++showID current++", hist size "++show (S.size hist)) + case resp of + Done ans -> do dbgPr (" !! Final result, answer "++show ans) + kont ans + Request key2 newCont + -- Here we have hit a cycle, and label it as such for the CURRENT node. + | S.member key2 hist -> do + dbgPr (" Stopping before hitting a cycle on "++showID key2++", call cycHndlr on "++showID current) + ans <- cycHndlr current + kont ans + | otherwise -> do + dbgPr (" Requesting child computation with key "++showWID key2) + resp' <- initCont key2 + loop key2 (S.insert key2 hist) resp' $ \ ans2 -> do + dbgPr (" DONE blocking on child key, cont invoked with answer: "++show ans2) + resp'' <- newCont ans2 + -- Popping back to processing the current key, which may not be finished. + loop current hist resp'' kont + +-- -- if wasloop then do +-- if False then do +-- -- Here the child computation ended up being processed as a cycle, so we must be as well: +-- dbgPr (" Child comp "++showID key2++" of "++showID current++" hit a cycle...") +-- ans3 <- cycHndlr current +-- kont (True,ans3) + + +-------------------------------------------------------------------------------- + +type IsCycle = Bool + +-- | The handler at a particular node (key) in the graph. This takes as argument a +-- key, along with a boolean indicating whether the current node has been found to +-- be part of a cycle. +-- +-- Also, for each child node, this handler is provided a way to demand the +-- resulting value of that child node, plus an indication of whether the child node +-- participates in a cycle. +-- +-- Finally, this handler is expected to produce a value which becomes associated +-- with the key. +type NodeAction d s k v = +-- Bool -> k -> [(Bool,Par d s v)] -> Par d s v + IsCycle -> k -> [(k,IsCycle,IV.IVar s v)] -> Par d s (NodeValue k v) + -- One thing that's missing here is WHICH child node(s) puts us in a cycle. + +-- | At the end of the handler execution, the value of a node is either ready, or it +-- is instead deferred to be exactly the value provided by another key. +data NodeValue k v = FinalValue !v | Defer k + deriving (Show,Eq,Ord) + + +-- | This combinator provides parallel exploration of a graph that contains cycles. +-- The limitation is that the work to be performed at each node (`NodeAction`) is not +-- invoked until the graph is fully traversed, i.e. after a barrier. Thus the graph +-- explored is not a "dynamic graph" in the sense of being computed on the fly by the +-- `NodeAction`. +-- +-- The algorithm used in this function is fairly expensive. For each node, it uses a +-- monotonic data structure to track the full set of other nodes that can reach it in +-- the graph. +#ifdef DEBUG_MEMO +exploreGraph :: forall s k v . (Ord k, Eq v, ShortShow k, Show v) => +#else +exploreGraph :: forall s k v . (Ord k, Eq v, Show k, Show v) => +#endif + (k -> Par QuasiDet s [k]) -- ^ Sketch the graph: map a key onto its children. + -> NodeAction QuasiDet s k v -- ^ The computation to run at each graph node. + -> k -- ^ The initial node (key) from which to explore. + -> Par QuasiDet s v +exploreGraph keyNbrs nodeHndlr initKey = do + + -- First: propogate key requests. + -- This will not diverge because the Set here suppressed duplicate callbacks: + set <- IS.newEmptySet + -- The map stores results: + mp <- IM.newEmptyMap + + keywalkHP <- newPool + + IS.forEachHP (Just keywalkHP) set $ \ key0 -> do + dbgPr ("![MemoFixedPoint] Start new key "++show key0) + -- Make some empty space for results: + key0_res <- IV.new + key0_cycle <- IV.new + key0_reach <- IS.newEmptySet + -- Next fetch the child node identities: + child_keys <- keyNbrs key0 + IM.insert key0 (NodeRecord key0 child_keys key0_reach key0_cycle key0_res) mp + dbgPr (" Computed nbrs of "++showID key0++" to be: "++ (showIDs child_keys)) + + case child_keys of + [] -> return () -- IV.put_ key0_cycle False + _ -> do + -- Spawn traversals of child nodes: + forM_ child_keys (`IS.insert` set) + + -- Establish the (expensive) cycle-checker handler: + IS.forEachHP (Just keywalkHP) key0_reach $ \ key1 -> + when (key1 == key0) $ do + dbgPr (" !! Cycle detected on key "++showID key0) + IV.put_ key0_cycle True + + -- Now we must wait for records to come up, and establish ourselves as upstream + -- of each child: + chldrecs <- forM child_keys $ \child -> do + nrec@NodeRecord{reachme} <- IM.getKey child mp + IS.insert key0 reachme -- Child is reachable from us. + -- Further, what reaches us, reaches the child: + copyTo keywalkHP key0_reach reachme + dbgPr (" Inserted ourselves ("++showID key0++") in reachme list of child: "++showID child) + return nrec + + -- If all our children are do not participate in a cycle, neither do we. + -- fork $ let loop [] = IV.put_ key0_cycle False + -- loop (NodeRecord{in_cycle}:tl) = do + -- bl <- IV.get in_cycle + -- case bl of + -- True -> return () + -- False -> loop tl + -- in loop chldrecs + -- FINISHME: If we have some cycle children and some leafish ones.... + -- then we may need to do an unsafe peek at our reachme set, no? + return () + + IS.insert initKey set + quiesce keywalkHP + -- fset <- IS.freezeSet set + frmap <- IM.freezeMap mp + + dbgPr ("Froze map: "++show (M.keys frmap)) + + -- TODO: need parallel traversable: + let getcyc vr = do mb <- IV.freezeIVar vr + if mb == Just True + then return True + else return False + showCyc bl = if bl then "cycle" else "Nocyc" + fn NodeRecord{mykey, chldrn, reachme,in_cycle=mecyc,result=myres} () = fork$ do + bl <- getcyc mecyc + bls <- mapM (getcyc . in_cycle . (frmap #)) chldrn + dbgPr (" !! Invoking node handler at key "++showID mykey++" "++ + showCyc bl ++" chldrn "++concat (intersperse " "$ map showCyc bls)) + x <- nodeHndlr bl mykey [ (k, b, result (frmap # k)) | b <- bls + | k <- chldrn ] + case x of + FinalValue vv -> do + dbgPr (" !! Writing result into key "++showID mykey++" value: "++show x) + IV.put_ myres vv + Defer tokey -> do dbgPr (" !! No result yet on key "++showID mykey++", DEFERing to key "++showID tokey) + fork $ do kv <- IV.get (result(frmap # tokey)) + dbgPr (" .. Delegated key "++showID tokey++", of key "++showID mykey++" produced result: "++show kv) + IV.put_ myres kv + F.foldrM fn () frmap + + let NodeRecord{result} = frmap # initKey + final <- IV.get result + ------------------------------------------------------------ + -- TEMP: Debugging + ------------------------------------------------------------ +#ifdef DEBUG_MEMO + when (dbg_lvl >= 4) $ do + dbgPr ("| START creating dot graph...") + dg <- debugVizMemoGraph True initKey frmap + unsafePerformIO (GV.runGraphviz dg GV.Pdf "MemoCyc_short.pdf") + `seq` return () + dg <- debugVizMemoGraph False initKey frmap + unsafePerformIO (GV.runGraphviz dg GV.Pdf "MemoCyc.pdf") + `seq` return () + dbgPr ("| DONE creating dot graph...") +#endif + ------------------------------------------------------------ + return final +-- return $! Memo set mp + +{- + + +-- | This version watches for, and catches, cyclic requests to the memotable that +-- would normally diverge. Once caught, the user specifies what to do with these +-- cycles by providing a handler. The handler is called on the key which formed the +-- cycle. That is, computing the invocation spawned by that key results in a demand +-- for that key. +makeMemoCyclic :: (MemoTable d s a b -> a -> Par d s b) -> (a -> Par d s b) -> Par d s (MemoTable d s a b) +makeMemoCyclic normalFn ifCycle = undefined +-- FIXME: Are there races where more than one cycle can be hit? Can we guarantee +-- that all are hit? + + + +-- | Cancel an outstanding speculative computation. This recursively attempts to +-- cancel any downstream computations in this or other memo-tables that are children +-- of the given `MemoFuture`. +cancel :: MemoFuture Det s b -> Par Det s () +-- FIXME: Det needs to be replaced here with "GetOnly". +cancel fut = undefined + +-} + +-------------------------------------------------------------------------------- +-- Misc Helpers and Utilities +-------------------------------------------------------------------------------- + +(#) :: (Ord a1, Show a1) => M.Map a1 a -> a1 -> a +m # k = case M.lookup k m of + Nothing -> error$ "Key was missing from map: "++show k + Just x -> x + +showMapContents :: (Eq t1, Show a, Show a1) => IM.IMap a1 s (IORef (Set a), IV.IVar t t1) -> IO String +showMapContents (IM.IMap lv) = do + mp <- readIORef (LV.state lv) + let lst = M.toList mp + return$ " Map Contents: (length "++ show (length lst) ++")\n" ++ + concat [ " "++fullempt++" "++showWID k++" -> "++vals++"\n" + | (k,(v,IV.IVar ivr)) <- lst +-- , let vals = "hello" + , let lst = S.toList $ unsafePerformIO (readIORef v) + , let vals = "#"++show (length lst)++"["++ (concat $ intersperse ", " $ map showID lst) ++"]" + , let fullempt = if Nothing == unsafePerformIO (readIORef (LV.state ivr)) + then "[empty]" + else "[full]" + ] + +showMapContents2 :: (Eq t3, Show t1, Show a) => IM.IMap a s (ISet t t1, IV.IVar t2 t3) -> IO String +showMapContents2 (IM.IMap lv) = do + mp <- readIORef (LV.state lv) + let lst = M.toList mp + return$ " Map Contents: (length "++ show (length lst) ++")\n" ++ + concat [ " "++fullempt++" "++showWID k++" -> "++vals++"\n" + | (k,(IS.ISet setlv, IV.IVar ivr)) <- lst +-- , let vals = "hello" + , let lst = S.toList $ unsafePerformIO (readIORef (LV.state setlv)) + , let vals = "#"++show (length lst)++"["++ (concat $ intersperse ", " $ map showID lst) ++"]" + , let fullempt = if Nothing == unsafePerformIO (readIORef (LV.state ivr)) + then "[empty]" + else "[full]" + ] + +-- | Variant of `union` that optionally ties the handlers in the resulting set to the same +-- handler pool as those in the two input sets. +copyTo :: Ord a => HandlerPool -> IS.ISet s a -> IS.ISet s a -> Par d s () +copyTo hp sfrom sto = do + IS.forEachHP (Just hp) sfrom (`insert` sto) + +{-# INLINE dbgPr #-} +dbgPr :: Monad m => String -> m () +#ifdef DEBUG_MEMO +dbgPr s | dbg_lvl >= 1 = trace s (return ()) + | otherwise = return () +#else +dbgPr _ = return () +#endif + +showWID :: Show a => a -> String +showWID x = let str = (show x) in + if length str < 10 + then str + else showID x++"__"++str + +showID :: Show a => a -> String +showID x = let str = (show x) in + if length str < 10 then str + else (show (length str))++"-"++ show (checksum str) + +showIDs ls = ("{"++(concat$ intersperse ", " $ map showID ls)++"}") + +checksum :: String -> Int +checksum str = sum (map ord str) + + +-------------------------------------------------------------------------------- +-- DEBUGGING +-------------------------------------------------------------------------------- + +-- | A show class that tries to stay under a budget. +class Show t => ShortShow t where + shortShow :: Int -> t -> String + shortShow n x = take n (show x) + +instance ShortShow Bool where + shortShow 1 True = "t" + shortShow 1 False = "f" + shortShow 2 True = "#t" + shortShow 2 False = "#f" + shortShow n b = take n (show b) + +instance ShortShow Integer where shortShow = shortShowNum +instance ShortShow Int where shortShow = shortShowNum +instance ShortShow Int8 where shortShow = shortShowNum +instance ShortShow Int16 where shortShow = shortShowNum +instance ShortShow Int32 where shortShow = shortShowNum +instance ShortShow Int64 where shortShow = shortShowNum + +shortShowNum :: Show a => Int -> a -> String +shortShowNum n num = + let str = show num + len = length str in + if len > n then + (take (n-2) str)++".." + else str + +instance ShortShow String where + shortShow n str = + let len = length str in + if len > 2 && n ==2 + then ".." + else if len > 1 && n == 1 + then "?" + else take n str + +instance (ShortShow a, ShortShow b) => ShortShow (a,b) where + shortShow 1 _ = "?" + shortShow 2 _ = ".." + shortShow n (a,b) = let (l,r) = shortTwo (n-3) a b + in "("++ l ++","++ r ++")" + +-- | Combine two things within a given size budget. +shortTwo :: (ShortShow t, ShortShow t1) => Int -> t -> t1 -> (String, String) +-- this could be better... +shortTwo n a b = (left, shortShow (half+remain) b) + where + remain = abs (half - length left) + left = shortShow half a + (q,r) = quotRem (abs(n-3)) 2 + half = q + r + +-------------------------------------------------------------------------------- + +#ifdef DEBUG_MEMO + +-- | Debugging flag shared by all accelerate-backend-kit modules. +-- This is activated by setting the environment variable DEBUG=1..5 +dbg_lvl :: Int +dbg_lvl = case lookup "DEBUG" theEnv of + Nothing -> defaultDbg + Just "" -> defaultDbg + Just "0" -> defaultDbg + Just s -> + trace (" ! Responding to env Var: DEBUG="++s)$ + case reads s of + ((n,_):_) -> n + [] -> error$"Attempt to parse DEBUG env var as Int failed: "++show s + +theEnv :: [(String, String)] +theEnv = unsafePerformIO getEnvironment + +defaultDbg :: Int +defaultDbg = 0 + +debugVizMemoGraph :: forall s t t1 t2 . (Ord t1, ShortShow t1, Show t2, F.Foldable t) => + Bool -- ^ Use shorter `showID` for keys. + -> t1 -- ^ The inital key. + -> t (NodeRecord s t1 t2) -- ^ A frozen map of graph nodes. +-- Par d s (Gr (Bool,String) ()) + -> Par QuasiDet s (GV.DotGraph G.Node) +debugVizMemoGraph idOnly initKey frmap = do + let showKey = if idOnly then showID + else shortShow 40 + let gcons :: NodeRecord s t1 t2 + -> (M.Map t1 G.Node, G.Gr (Bool,t1,t2) ()) + -> Par QuasiDet s (M.Map t1 G.Node, G.Gr (Bool,t1,t2) ()) + gcons NodeRecord{mykey, in_cycle,result} + (labmap, gracc) = do + dbgPr (" .. About to wait for node result, key "++show mykey) + res <- IV.get result + dbgPr (" .. About to wait for node in_cycle, key "++show mykey) + cyc <- IV.freezeIVar in_cycle + let num = 1 + G.noNodes gracc + gr' = G.insNode (num, (cyc == Just True,mykey,res)) $ + gracc + labmap' = M.insert mykey num labmap + return (labmap',gr') + + gedges :: NodeRecord s t1 t2 + -> (M.Map t1 G.Node, G.Gr (Bool,t1,t2) ()) + -> Par d s (M.Map t1 G.Node, G.Gr (Bool,t1,t2) ()) + gedges NodeRecord{mykey, chldrn } + (labmap, gracc) = do + let chldnodes = map (labmap #) chldrn + num = labmap # mykey + gr' = G.insEdges [ (num,cnd::Int,()) | cnd <- chldnodes ] $ + gracc + labmap' = M.insert mykey num labmap + return (labmap',gr') + + dbgPr (" !! Creating graphviz graph from MemoCyc map of size "++show (F.foldr (\ _ n -> 1+n) 0 frmap)) +-- dbgPr (" !! All keys "++show frmap) + + -- Two passes, first add nodes, then edges: + (lm,graph0) <- F.foldrM gcons (M.empty, G.empty) frmap + dbgPr (" .. Added all nodes to the graph...") + (_,graph) <- F.foldrM gedges (lm, graph0) frmap + dbgPr (" .. Added all edges to the graph...") + let -- dg = graphToDot nonClusteredParams graph + myparams :: GV.GraphvizParams G.Node (Bool,t1,t2) () () (Bool,t1,t2) + myparams = GV.defaultParams { GV.fmtNode= nodeAttrs } + + nodeAttrs :: (Int, (Bool,t1,t2)) -> [GA.Attribute] +-- nodeAttrs :: (Int, String) -> [GA.Attribute] + nodeAttrs (_num, (cyc,key,res)) = + let lbl = showKey key++"\n=> "++ show res in + [ GA.Label$ GA.StrLabel $ pack lbl ] ++ + (if key == initKey + then [GA.Color [weighted$ GA.X11Color GV.Red]] + else []) ++ + (if cyc then [] + else [GA.Shape GA.BoxShape]) + + dg = GV.graphToDot myparams graph -- (G.nmap uid graph) + return dg + +weighted c = GC.WC {GC.wColor=c, GC.weighting=Nothing} + +#endif +-- End DEBUG_MEMO diff --git a/Data/LVar/Generic.hs b/Data/LVar/Generic.hs --- a/Data/LVar/Generic.hs +++ b/Data/LVar/Generic.hs @@ -8,7 +8,8 @@ module Data.LVar.Generic ( -- * Classes containing the generic interfaces - LVarData1(..), OrderedLVarData1(..), + LVarData1(..), LVarWBottom(..), + OrderedLVarData1(..), -- * Supporting types and utilities AFoldable(..), @@ -16,7 +17,9 @@ ) where -import Control.LVish +import Control.LVish.Types +import Control.LVish.Basics +import Control.LVish.Internal (Par, Determinism(..)) import Control.LVish.DeepFrz.Internal (Frzn, Trvrsbl) import qualified Data.Foldable as F import Data.List (sort) diff --git a/Data/LVar/Generic/Internal.hs b/Data/LVar/Generic/Internal.hs --- a/Data/LVar/Generic/Internal.hs +++ b/Data/LVar/Generic/Internal.hs @@ -6,6 +6,8 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies, ConstraintKinds #-} + {-| This module contains the unsafe bits that we cannot expose from @@ -14,17 +16,23 @@ -} module Data.LVar.Generic.Internal - (LVarData1(..), AFoldable(..), + (LVarData1(..), LVarWBottom (..), + AFoldable(..), unsafeCoerceLVar, unsafeTraversable) where -import Control.LVish +import Control.LVish.Types +import Control.LVish.Basics +import Control.LVish.Internal (Par, Determinism(..)) +import Control.LVish.SchedIdempotent (HandlerPool) import Control.LVish.DeepFrz.Internal (Frzn, Trvrsbl) import qualified Data.Foldable as F import Data.List (sort, intersperse) import GHC.Prim (unsafeCoerce#) import System.IO.Unsafe (unsafeDupablePerformIO) +import GHC.Prim (Constraint) + ------------------------------------------------------------------------------ -- Interface for generic LVar handling ------------------------------------------------------------------------------ @@ -37,8 +45,6 @@ -- TODO: if there is a Par class to generalize LVar Par monads, then -- it needs to be a superclass of this. where - -- type LVCtxt (f :: * -> * -> *) (s :: *) (a :: *) :: Constraint - -- I was not able to get abstracting over the constraints to work. -- | Add a handler function which is called whenever an element is -- added to the LVar. @@ -53,8 +59,7 @@ -- -- However, note that `Frzn` LVars cannot be folded, because they may have -- nondeterministic ordering after being frozen. See `sortFreeze`. - freeze :: -- LVCtxt f s a => - f s a -> Par QuasiDet s (f Frzn a) + freeze :: f s a -> Par QuasiDet s (f Frzn a) -- | Perform a freeze followed by a /sort/ operation which guarantees -- that the elements produced will be produced in a deterministic order. @@ -68,6 +73,15 @@ -- Without a traversible instance we cannot reconstruct an ordered -- version of the LVar contents with its original type: in AFoldable ls' + +-- | A class enabling generic creation of new LVars. +class LVarWBottom (f :: * -> * -> *) where + -- | Requirements for contents types of this LVar. + type LVContents f a :: Constraint + + newBottom :: (LVContents f a) => Par d s (f s a) + + -- singletonLV :: (LVContents f a) => a -> Par d s (f s a) -- | Carries a `Foldable` type, but you don't get to know which one. -- The purpose of this type is that `sortFreeze` should not have diff --git a/Data/LVar/IStructure.hs b/Data/LVar/IStructure.hs --- a/Data/LVar/IStructure.hs +++ b/Data/LVar/IStructure.hs @@ -22,7 +22,10 @@ put, put_, get, getLength, -- * Iteration and callbacks - forEachHP + forEachHP, + + -- * Freezing + freezeIStructure -- forEach, ) where @@ -37,7 +40,7 @@ import Data.List (intersperse) -- import qualified Data.Traversable as T -import Control.LVish as LV +import Control.LVish as LV hiding (put,put_,get) import Control.LVish.DeepFrz.Internal import Control.LVish.Internal as LI import Control.LVish.SchedIdempotent (newLV, putLV, getLV, freezeLV, @@ -140,9 +143,7 @@ -- | /O(N)/ complexity, unfortunately. This implementation of `IStructure`s requires -- freezing each of the individual IVars stored in the array. freezeIStructure :: IStructure s a -> LV.Par QuasiDet s (V.Vector (Maybe a)) -freezeIStructure (IStructure vec) = do - v <- V.mapM IV.freezeIVar vec - return v +freezeIStructure (IStructure vec) = V.mapM IV.freezeIVar vec {-# INLINE forEachHP #-} -- | Add an (asynchronous) callback that listens for all new elements added to diff --git a/Data/LVar/IVar.hs b/Data/LVar/IVar.hs --- a/Data/LVar/IVar.hs +++ b/Data/LVar/IVar.hs @@ -50,17 +50,20 @@ import System.IO.Unsafe (unsafePerformIO, unsafeDupablePerformIO) import qualified Data.Foldable as F import Control.Exception (throw) -import Control.LVish as LV +import qualified Control.LVish.Types as LV +import qualified Control.LVish.Basics as LV import Control.LVish.DeepFrz.Internal -import Control.LVish.Internal as I +import qualified Control.LVish.Internal as I +import Control.LVish.Internal (Par(WrapPar), LVar(WrapLVar), Determinism(QuasiDet)) import Control.LVish.SchedIdempotent (newLV, putLV, getLV, freezeLV) import qualified Control.LVish.SchedIdempotent as LI import Data.LVar.Generic import Data.LVar.Generic.Internal (unsafeCoerceLVar) import GHC.Prim (unsafeCoerce#) -#ifdef USE_ABSTRACT_PAR -import qualified Control.Monad.Par.Class as PC +#ifdef GENERIC_PAR +import qualified Control.Par.Class as PC +import qualified Control.Par.Class.Unsafe as PC #endif ------------------------------------------------------------------------------ @@ -74,7 +77,7 @@ -- | Physical equality, just as with `IORef`s. instance Eq (IVar s a) where - (==) (IVar lv1) (IVar lv2) = state lv1 == state lv2 + (==) (IVar lv1) (IVar lv2) = I.state lv1 == I.state lv2 -- | An `IVar` can be treated as a generic container LVar which happens to -- contain at most one value! Note, however, that the polymorphic operations are @@ -86,6 +89,10 @@ return (unsafeCoerceLVar orig) addHandler = whenFull +instance LVarWBottom IVar where + type LVContents IVar a = () + newBottom = new + -- Just a type-coercion. No bits flipped at runtime. instance DeepFrz a => DeepFrz (IVar s a) where type FrzType (IVar s a) = IVar Frzn (FrzType a) @@ -95,13 +102,13 @@ -- a fixed order. instance F.Foldable (IVar Trvrsbl) where foldr fn zer (IVar lv) = - case unsafeDupablePerformIO$ readIORef (state lv) of + case unsafeDupablePerformIO$ readIORef (I.state lv) of Just x -> fn x zer Nothing -> zer instance (Show a) => Show (IVar Frzn a) where show (IVar lv) = - show $ unsafeDupablePerformIO $ readIORef (state lv) + show $ unsafeDupablePerformIO $ readIORef (I.state lv) -- | For convenience only; the user could define this. instance Show a => Show (IVar Trvrsbl a) where @@ -121,7 +128,7 @@ -- IVar. get :: IVar s a -> Par d s a get (IVar (WrapLVar iv)) = WrapPar$ getLV iv globalThresh deltaThresh - where globalThresh ref _ = readIORef ref -- past threshold iff Jusbt _ + where globalThresh ref _ = readIORef ref -- past threshold iff Just _ deltaThresh x = return $ Just x -- always past threshold {-# INLINE put_ #-} @@ -140,7 +147,7 @@ update Nothing = (Just x, Just x) -- | A specialized freezing operation for IVars that leaves the result in a handy format (`Maybe`). -freezeIVar :: IVar s a -> LV.Par QuasiDet s (Maybe a) +freezeIVar :: IVar s a -> I.Par QuasiDet s (Maybe a) freezeIVar (IVar (WrapLVar lv)) = WrapPar $ do freezeLV lv getLV lv globalThresh deltaThresh @@ -152,21 +159,22 @@ -- | Unpack a frozen IVar (as produced by a generic `freeze` operation) as a more -- palatable data structure. fromIVar :: IVar Frzn a -> Maybe a -fromIVar (IVar lv) = unsafeDupablePerformIO $ readIORef (state lv) +fromIVar (IVar lv) = unsafeDupablePerformIO $ readIORef (I.state lv) {-# INLINE whenFull #-} -- | Register a handler that fires when the IVar is filled, which, of course, only -- happens once. -whenFull :: Maybe HandlerPool -> IVar s a -> (a -> Par d s ()) -> Par d s () +whenFull :: Maybe LI.HandlerPool -> IVar s a -> (a -> Par d s ()) -> Par d s () whenFull mh (IVar (WrapLVar lv)) fn = WrapPar (LI.addHandler mh lv globalCB fn') where - fn' x = return (Just (unWrapPar (fn x))) + -- The threshold is ALWAYS met when a put occurs: + fn' x = return (Just (I.unWrapPar (fn x))) globalCB ref = do - mx <- readIORef ref -- Snapshot + mx <- LI.liftIO $ readIORef ref -- Snapshot case mx of - Nothing -> return Nothing - Just v -> fn' v + Nothing -> return () + Just v -> I.unWrapPar$ fn v -------------------------------------------------------------------------------- @@ -174,12 +182,12 @@ -- | A simple future represented as an IVar. The result is fully evaluated before -- the child computation returns. spawn :: (Eq a, NFData a) => Par d s a -> Par d s (IVar s a) -spawn p = do r <- new; fork (p >>= put r); return r +spawn p = do r <- new; LV.fork (p >>= put r); return r {-# INLINE spawn_ #-} -- | A version of `spawn` that uses only WHNF, rather than full `NFData`. spawn_ :: Eq a => Par d s a -> Par d s (IVar s a) -spawn_ p = do r <- new; fork (p >>= put_ r); return r +spawn_ p = do r <- new; LV.fork (p >>= put_ r); return r {-# INLINE spawnP #-} spawnP :: (Eq a, NFData a) => a -> Par d s (IVar s a) @@ -190,17 +198,16 @@ put :: (Eq a, NFData a) => IVar s a -> a -> Par d s () put v a = deepseq a (put_ v a) - -#ifdef USE_ABSTRACT_PAR - -- MIN_VERSION_abstract_par(0,4,0) -#warning "Using the latest version of abstract par to activate ParFuture/IVar instances." -instance PC.ParFuture (IVar s) (Par d s) where +#ifdef GENERIC_PAR +instance PC.ParFuture (Par d s) where + type Future (Par d s) = IVar s + type FutContents (Par d s) a = (Eq a) spawn_ = spawn_ get = get -instance PC.ParIVar (IVar s) (Par d s) where - fork = fork +instance PC.ParIVar (Par d s) where put_ = put_ new = new + #endif diff --git a/Data/LVar/Internal/Pure.hs b/Data/LVar/Internal/Pure.hs --- a/Data/LVar/Internal/Pure.hs +++ b/Data/LVar/Internal/Pure.hs @@ -21,7 +21,13 @@ module Data.LVar.Internal.Pure ( PureLVar(..), - newPureLVar, putPureLVar, waitPureLVar, freezePureLVar + newPureLVar, putPureLVar, + + waitPureLVar, freezePureLVar, + getPureLVar, unsafeGetPureLVar, + + -- * Verifying lattice structure + verifyFiniteJoin, verifyFiniteGet ) where import Control.LVish @@ -30,36 +36,124 @@ import Data.IORef import qualified Control.LVish.SchedIdempotent as LI import Algebra.Lattice -import GHC.Prim (unsafeCoerce#) - +import GHC.Prim (unsafeCoerce#) +import System.IO.Unsafe (unsafePerformIO) -------------------------------------------------------------------------------- -- | An LVar which consists merely of an immutable, pure value inside a mutable box. newtype PureLVar s t = PureLVar (LVar s (IORef t) t) +instance Show a => Show (PureLVar Frzn a) where + show (PureLVar lv) = show$ unsafePerformIO$ readIORef$ state lv + -- data PureLVar s t = BoundedJoinSemiLattice t => PureLVar (LVar s (IORef t) t) {-# INLINE newPureLVar #-} {-# INLINE putPureLVar #-} +{-# INLINE getPureLVar #-} {-# INLINE waitPureLVar #-} {-# INLINE freezePureLVar #-} +-- | Takes a finite set of states and a join operation (e.g., for an +-- instance of JoinSemiLattice) and returns an error message if the +-- join-semilattice properties don't hold. +verifyFiniteJoin :: (Eq a, Show a) => [a] -> (a -> a -> a) -> Maybe String +verifyFiniteJoin allStates join = + case (isCommutative, isAssociative, isIdempotent) of + (hd : _ , _, _) -> Just $ "commutativity violated!: " ++ show hd + (_ , hd : _, _) -> Just $ "associativity violated!: " ++ show hd + (_ , _, hd : _) -> Just $ "idempotency violated!: " ++ show hd + ([], [], []) -> Nothing + where + isCommutative = [(a, b) | a <- allStates, b <- allStates, a `join` b /= b `join` a] + isAssociative = [(a, b, c) | + a <- allStates, + b <- allStates, + c <- allStates, + a `join` (b `join` c) /= (a `join` b) `join` c] + isIdempotent = [a | a <- allStates, a `join` a /= a] + +-- | Verify that a blocking get is monotone in just the right way. +-- This takes a designated bottom and top element. +verifyFiniteGet :: (Eq a, Show a, JoinSemiLattice a, + Eq b, Show b) => + [a] -> (b,b) -> (a -> b) -> Maybe String +verifyFiniteGet allStates (bot,top) getter = + case (botBefore, constAfter) of + ((a,b):_, _) -> Just$ "violation! input "++ show a + ++" unblocked get, but larger input"++show b++" did not." + (_, (a,b):_) -> Just$ "violation! value at "++ show a + ++" was non-bottom ("++show (getter a) + ++"), but then changed at "++show b++" ("++ show (getter b)++")" + ([],[]) -> Nothing + where + botBefore = [ (a,b) + | a <- allStates, b <- allStates + , a `joinLeq` b, getter b == bot + , not (getter a == bot) ] + constAfter = [ (a,b) + | a <- allStates, b <- allStates + , a `joinLeq` b + , getter a /= bot + , getter a /= getter b + , getter b /= top -- It's ok to go to error. + ] + + -- | A new pure LVar populated with the provided initial state. -newPureLVar :: BoundedJoinSemiLattice t => +newPureLVar :: JoinSemiLattice t => t -> Par d s (PureLVar s t) newPureLVar st = WrapPar$ fmap (PureLVar . WrapLVar) $ LI.newLV $ newIORef st +-- | Blocks until the contents of `lv` are at or above one element of +-- `thrshSet`, then returns that one element. +getPureLVar :: (JoinSemiLattice t, Eq t) => PureLVar s t -> [t] -> Par d s t +getPureLVar (PureLVar (WrapLVar lv)) thrshSet = + WrapPar$ LI.getLV lv globalThresh deltaThresh + where globalThresh ref _ = do + x <- readIORef ref + logDbgLn_ 5 " [Pure] Getting from a Pure LVar.. read ref." + deltaThresh x + deltaThresh x = + return $ checkThresholds x thrshSet + +-- | Returns the element of thrshSet that `currentState` is above, if +-- it exists. (Assumes that there is only one such element!) +checkThresholds :: (JoinSemiLattice t, Eq t) => t -> [t] -> Maybe t +checkThresholds currentState thrshSet = case thrshSet of + [] -> Nothing + (thrsh : thrshs) -> if thrsh `joinLeq` currentState + then Just thrsh + else checkThresholds currentState thrshs + +-- | Like `getPureLVar` but uses a threshold function rather than an explicit set. +unsafeGetPureLVar :: (JoinSemiLattice t, Eq t) => PureLVar s t -> (t -> Bool) -> Par d s t +unsafeGetPureLVar (PureLVar (WrapLVar lv)) thrsh = + WrapPar$ LI.getLV lv globalThresh deltaThresh + where globalThresh ref _ = do + x <- readIORef ref + logDbgLn_ 5 " [Pure] unsafeGetPureLVar: read the ref." + deltaThresh x + deltaThresh x = + return $! if thrsh x + then Just x + else Nothing + -- | Wait until the pure LVar has crossed a threshold and then unblock. (In the -- semantics, this is a singleton query set.) waitPureLVar :: (JoinSemiLattice t, Eq t) => PureLVar s t -> t -> Par d s () waitPureLVar (PureLVar (WrapLVar iv)) thrsh = WrapPar$ LI.getLV iv globalThresh deltaThresh - where globalThresh ref _ = do x <- readIORef ref - deltaThresh x - deltaThresh x | thrsh `joinLeq` x = return $ Just () - | otherwise = return Nothing + where globalThresh ref _ = do + x <- readIORef ref + logDbgLn_ 5 " [Pure] checking global thresh..." + deltaThresh x + deltaThresh x | thrsh `joinLeq` x = do logDbgLn_ 5 " [Pure] Delta thresh met!" + return $ Just () + | otherwise = do logDbgLn_ 5 " [Pure] Check Delta thresh.. Not yet." + return Nothing -- | Put a new value which will be joined with the old. putPureLVar :: JoinSemiLattice t => @@ -68,7 +162,12 @@ WrapPar $ LI.putLV iv putter where -- Careful, this must be idempotent... - putter _ = return (Just new) + putter !ref = do + -- In some cases direct CAS would be better than atomicModifyIORef here. + logDbgLn_ 5 " [Pure] Putting to pure LVar.." + atomicModifyIORef' ref $ \ oldval -> (join oldval new, ()) + -- We still publish the change for delta-thresh's to respond to: + return $! Just $! new -- | Freeze the pure LVar, returning its exact value. -- Subsequent @put@s will raise an error. @@ -96,3 +195,5 @@ type FrzType (PureLVar s a) = PureLVar Frzn (FrzType a) frz = unsafeCoerce# +-- FIXME: need an efficient way to extract the logger and capture it in the callbacks: +logDbgLn_ _ _ = return () diff --git a/Data/LVar/MaxCounter.hs b/Data/LVar/MaxCounter.hs --- a/Data/LVar/MaxCounter.hs +++ b/Data/LVar/MaxCounter.hs @@ -12,7 +12,7 @@ newMaxCounter, put, waitThresh, freezeMaxCounter ) where -import Control.LVish hiding (freeze) +import Control.LVish hiding (freeze, put) import Control.LVish.Internal (state) import Control.LVish.DeepFrz.Internal import Data.IORef @@ -34,7 +34,7 @@ deriving (Eq, Show, Ord, Read) instance JoinSemiLattice MC where - join (MC a) (MC b) = MC (a `max` b) + join (MC !a) (MC !b) = MC (a `max` b) instance BoundedJoinSemiLattice MC where bottom = MC minBound diff --git a/Data/LVar/Memo.hs b/Data/LVar/Memo.hs new file mode 100644 --- /dev/null +++ b/Data/LVar/Memo.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE ScopedTypeVariables, DataKinds #-} +{-# LANGUAGE KindSignatures, EmptyDataDecls #-} +{-# LANGUAGE BangPatterns #-} +{-# OPTIONS_GHC -O2 #-} + +{-| + +This basic version of memotables is implemented on top of existing LVars without +breaking any rules. + +The problem is that it cannot do cycle detection, because that requires tracking +extra information (where we've been) which is NOT exposed to the user and NOT used + + -} +module Data.LVar.Memo + ( + -- * Memo tables and defered lookups + Memo, MemoFuture, makeMemo, + + -- * Memo table operations + getLazy, getMemo, force + ) where +import Debug.Trace + +import Control.LVish +import qualified Data.Set as S +-- import qualified Data.LVar.SLMap as IM +-- import Data.LVar.SLSet as IS +import qualified Data.LVar.PureMap as IM +import Data.LVar.PureSet as IS +import Data.LVar.IVar as IV + +-------------------------------------------------------------------------------- +-- Types +-------------------------------------------------------------------------------- + +-- | A Memo-table that stores cached results of executing a `Par` computation. +data Memo (d::Determinism) s a b = + Memo !(IS.ISet s a) + !(IM.IMap a s b) + +-- | A result from a lookup in a Memo-table, unforced. +-- The two-stage `getLazy`/`force` lookup is useful to separate +-- spawning the work from demanding its result. +newtype MemoFuture (d :: Determinism) s b = MemoFuture (Par d s b) + +-------------------------------------------------------------------------------- + +-- | Reify a function in the `Par` monad as an explicit memoization table. +makeMemo :: (Ord a, Eq b, Show a, Show b) => + (a -> Par d s b) -> Par d s (Memo d s a b) +makeMemo fn = do + st <- newEmptySet + mp <- IM.newEmptyMap + IS.forEach st $ \ elm -> do + res <- fn elm + trace ("makeMemo, about to insert result: "++show (show elm, show res)) $ + IM.insert elm res mp + return $! Memo st mp +-- TODO: this version may want to have access to the memo-table within the handler as +-- well.... + + +-- | Read from the memo-table. If the value must be computed, do that right away and +-- block until its complete. +getMemo :: (Ord a, Eq b) => Memo d s a b -> a -> Par d s b +getMemo tab key = + do fut <- getLazy tab key + force fut + +-- | Begin to read from the memo-table. Initiate the computation if the key is not +-- already present. Don't block on the computation being complete, rather, return a +-- future. +getLazy :: (Ord a, Eq b) => Memo d s a b -> a -> Par d s (MemoFuture d s b) +getLazy (Memo st mp) key = do + IS.insert key st + return $! MemoFuture (IM.getKey key mp) + + +-- | This will throw exceptions that were raised during the computation, INCLUDING +-- multiple put. +force :: MemoFuture d s b -> Par d s b +force (MemoFuture pr) = pr +-- FIXME!!! Where do errors in the memoized function (e.g. multiple put) surface? +-- We must pick a determined, consistent place. +-- +-- Multiple put errors may not be able to wait until this point to get +-- thrown. Otherwise we'd have to be at least quasideterministic here. If you have +-- a MemoFuture you never force, it and an outside computation may be racing to do a +-- put. If the outside one wins the MemoFuture is the one that gets the exception +-- (and hides it), otherwise the exception is exposed. Quasideterminism. + +-- It may be fair to distinguish between internal problems with the MemoFuture +-- (deferred exceptions), and problematic interactions with the outside world (double +-- put) which would then not be deferred. Such futures can't be canceled anyway, so +-- there's really no need to defer the exceptions. + + + +{- + + +-- | Cancel an outstanding speculative computation. This recursively attempts to +-- cancel any downstream computations in this or other memo-tables that are children +-- of the given `MemoFuture`. +cancel :: MemoFuture Det s b -> Par Det s () +-- FIXME: Det needs to be replaced here with "GetOnly". +cancel fut = undefined + +-} diff --git a/Data/LVar/NatArray.hs b/Data/LVar/NatArray.hs new file mode 100644 --- /dev/null +++ b/Data/LVar/NatArray.hs @@ -0,0 +1,284 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE GADTs #-} + +{-| + +An I-structure (array) of /positive/ numbers. A `NatArray` cannot store zeros. + +This particular implementation makes a trade-off between expressiveness (monomorphic +in array contents) and efficiency. The efficiency gained of course is that the array +may be unboxed, and we don't need extra bits to store empty/full status. + +/However/, relative to "Data.LVar.IStructure", there is a performance disadvantage as +well. As of [2013.09.28] and their initial release, `NatArray`s are implemented as a +/single/ `LVar`, which means they share a single wait-list of blocked computations. +If there are many computations blocking on different elements within a `NatArray`, +scalability will be much worse than with other `IStructure` implementations. + +The holy grail is to get unboxed arrays and scalable blocking, but we don't have this +yet. + +Finally, note that this data-structure has an EXPERIMENTAL status and may be removed +in future releases as we find better ways to support unboxed array structures with +per-element synchronization. + +-} + +module Data.LVar.NatArray + ( + -- * Basic operations + NatArray, + newNatArray, put, get, + + -- * Iteration and callbacks + forEach, forEachHP + + -- -- * Quasi-deterministic operations + -- freezeSetAfter, withCallbacksThenFreeze, freezeSet, + + -- -- * Higher-level derived operations + -- copy, traverseSet, traverseSet_, union, intersection, + -- cartesianProd, cartesianProds, + + -- -- * Alternate versions of derived ops that expose HandlerPools they create. + -- forEachHP, traverseSetHP, traverseSetHP_, + -- cartesianProdHP, cartesianProdsHP + ) where + +-- import qualified Data.Vector.Unboxed as U +-- import qualified Data.Vector.Unboxed.Mutable as M + + +import Data.LVar.NatArray.Unsafe + +import qualified Data.Vector.Storable as U +import qualified Data.Vector.Storable.Mutable as M +import Foreign.Marshal.MissingAlloc (callocBytes) +import Foreign.Marshal.Alloc (finalizerFree) +import Foreign.Storable (sizeOf, Storable) +import Foreign.ForeignPtr (newForeignPtr, withForeignPtr) +import qualified Foreign.Ptr as P +import qualified Data.Bits.Atomic as B +import Data.Bits ((.&.)) + +import Control.Monad (void) +import Control.Exception (throw) +import Data.IORef +import Data.Maybe (fromMaybe) +import qualified Data.Set as S +import qualified Data.LVar.IVar as IV +import qualified Data.Foldable as F +import qualified Data.Traversable as T +import Data.LVar.Generic + +import Control.LVish as LV hiding (addHandler, put,get) +import Control.LVish.DeepFrz.Internal as DF +import Control.LVish.Internal as LI +import Control.LVish.SchedIdempotent (newLV, putLV, getLV, freezeLV, + freezeLVAfter, liftIO) +import qualified Control.LVish.SchedIdempotent as L +import System.IO.Unsafe (unsafeDupablePerformIO) +import Data.LVar.NatArray.Unsafe (NatArray(..)) + +------------------------------------------------------------------------------ +-- Toggles + +#define USE_CALLOC +-- A low-level optimization below. + +------------------------------------------------------------------------------ + +unNatArray (NatArray lv) = lv + +-- | Physical identity, just as with IORefs. +-- instance Eq (NatArray s v) where +-- NatArray lv1 == NatArray lv2 = state lv1 == state lv2 + +-- | Create a new, empty, monotonically growing 'NatArray' of a given size. +-- All entries start off as zero, which must be BOTTOM. +newNatArray :: forall elt d s . (Storable elt, Num elt) => + Int -> Par d s (NatArray s elt) +newNatArray len = WrapPar $ fmap (NatArray . WrapLVar) $ newLV $ do +#ifdef USE_CALLOC + let bytes = sizeOf (undefined::elt) * len + mem <- callocBytes bytes + fp <- newForeignPtr finalizerFree mem + return $! M.unsafeFromForeignPtr0 fp len +#else + M.replicate len 0 +#endif + +-- | /O(1)/ Freeze operation that directly returns a nice, usable, representation of +-- the array data. +freezeNatArray :: Storable a => NatArray s a -> LV.Par QuasiDet s (U.Vector a) +freezeNatArray (NatArray lv) = do +-- freezeLV +-- U.unsafeFreeze (state lv)) + error "FINISHME -- freezeNatArray " + -- LI.liftIO $ U.unsafeFreeze (LI.state lv) + +-------------------------------------------------------------------------------- +-- Instances: + +-- FIXME: there is a tension here.. should NatArray really be a generic LVarData1 at all? +-- Can it really store anything in Storable!?!? Or do we need to fix it to numbers +-- to ensure the zero-trick makes sense? + +{- + +instance DeepFrz a => DeepFrz (NatArray s a) where + type FrzType (NatArray s a) = NatArray Frzn (FrzType a) + frz = unsafeCoerceLVar + +-- | /O(1)/: Convert from a frozen `NatArray` to a plain vector. +-- This is only permitted when the `NatArray` has already been frozen. +-- This is useful for processing the result of `Control.LVish.DeepFrz.runParThenFreeze`. +fromNatArray :: NatArray Frzn a -> U.Vector a +fromNatArray (NatArray lv) = unsafeDupablePerformIO (readIORef (state lv)) + +-} + +-------------------------------------------------------------------------------- + +{-# INLINE forEachHP #-} +-- | Add an (asynchronous) callback that listens for all new elements added to +-- the array, optionally enrolled in a handler pool. +forEachHP :: (Storable a, Eq a, Num a) => + Maybe HandlerPool -- ^ pool to enroll in, if any + -> NatArray s a -- ^ array to listen to + -> (Int -> a -> Par d s ()) -- ^ callback + -> Par d s () +forEachHP hp (NatArray (WrapLVar lv)) callb = WrapPar $ do + L.addHandler hp lv globalCB deltaCB + return () + where + deltaCB (ix,x) = return$ Just$ unWrapPar$ callb ix x + globalCB vec = unWrapPar$ + -- FIXME / TODO: need a better (parallel) for loop: + forVec vec $ \ ix elm -> + -- FIXME: When it starts off, it is SPARSE... there must be a good way to + -- avoid testing each position for zero. + if elm == 0 + then return () + else forkHP hp $ callb ix elm + +{-# INLINE forVec #-} +-- | Simple for-each loops over vector elements. +forVec :: Storable a => + M.IOVector a -> (Int -> a -> Par d s ()) -> Par d s () +forVec vec fn = loop 0 + where + len = M.length vec + loop i | i == len = return () + | otherwise = do elm <- LI.liftIO$ M.unsafeRead vec i + fn i elm + loop (i+1) + +{-# INLINE forEach #-} +-- | Add an (asynchronous) callback that listens for all new elements added to +-- the set +forEach :: (Num a, Storable a, Eq a) => + NatArray s a -> (Int -> a -> Par d s ()) -> Par d s () +forEach = forEachHP Nothing + + +{-# INLINE put #-} +-- | Put a single element in the array. That slot must be previously empty. (WHNF) +-- Strict in the element being put in the set. +put :: forall s d elt . (Storable elt, B.AtomicBits elt, Num elt, Show elt) => + NatArray s elt -> Int -> elt -> Par d s () +put _ !ix 0 = throw (LVarSpecificExn$ "NatArray: violation! Attempt to put zero to index: "++show ix) +put (NatArray (WrapLVar lv)) !ix !elm = WrapPar$ putLV lv (putter ix) + where putter ix vec@(M.MVector _len fptr) = + withForeignPtr fptr $ \ ptr -> do + let offset = sizeOf (undefined::elt) * ix + -- ARG, if it weren't for the idempotency requirement we could use fetchAndAdd here: + -- orig <- B.fetchAndAdd (P.plusPtr ptr offset) elm + orig <- B.compareAndSwap (P.plusPtr ptr offset) 0 elm + case orig of + 0 -> return (Just (ix, elm)) + i | i == elm -> return Nothing -- Allow repeated, equal puts. + | otherwise -> throw$ ConflictingPutExn$ "Multiple puts to index of a NatArray: "++ + show ix++" new/old : "++show elm++"/"++show orig + +{-# INLINE get #-} +-- | Wait for an indexed entry to contain a non-zero value. +-- +-- Warning: this is inefficient if it needs to block, because the deltaThresh must +-- monitor EVERY new addition. +get :: forall s d elt . (Storable elt, B.AtomicBits elt, Num elt) => + NatArray s elt -> Int -> Par d s elt +get (NatArray (WrapLVar lv)) !ix = WrapPar $ + getLV lv globalThresh deltaThresh + where + globalThresh ref _frzn = do + elm <- M.read ref ix + if elm == 0 + then return Nothing + else return (Just elm) + -- FIXME: we don't actually want to call the deltaThresh on every element... + -- We want more locality than that... + deltaThresh (ix2,e2) | ix == ix2 = return$! Just e2 + | otherwise = return Nothing + + +-- | A sequential for-loop with a catch. The body of the loop gets access to a +-- special get function. This getter will not block subsequent iterations of the +-- loop. Parallelism will be introduced minimally, only as neccessary to avoid +-- blocking. +seqLoopNonblocking :: Int -> Int -> + ((NatArray s elt -> Int -> Par d s elt) -> Int -> Par d s ()) -> + Par d s () +seqLoopNonblocking start end fn = do + error "TODO - FINISHME: seqLoopNonblocking optimization" + where + par = + L.Par $ \k -> L.ClosedPar $ \q -> do + -- tripped <- globalThresh state False +-- case tripped of + -- Just b -> exec (k b) q -- already past the threshold; invoke the +-- forkHP mh child = mkPar $ \k q -> do +-- closed <- closeInPool mh child +-- Sched.pushWork q (k ()) -- "Work-first" policy. +-- -- hpMsg " [dbg-lvish] incremented and pushed work in forkInPool, now running cont" hp +-- exec closed q + undefined + +{- +parFor :: (ParFuture iv p) => InclusiveRange -> (Int -> p ()) -> p () +parFor (InclusiveRange start end) body = + do + let run (x,y) = for_ x (y+1) body + range_segments = splitInclusiveRange (4*numCapabilities) (start,end) + + vars <- M.forM range_segments (\ pr -> spawn_ (run pr)) + M.mapM_ get vars + return () + +splitInclusiveRange :: Int -> (Int, Int) -> [(Int, Int)] +splitInclusiveRange pieces (start,end) = + map largepiece [0..remain-1] ++ + map smallpiece [remain..pieces-1] + where + len = end - start + 1 -- inclusive [start,end] + (portion, remain) = len `quotRem` pieces + largepiece i = + let offset = start + (i * (portion + 1)) + in (offset, offset + portion) + smallpiece i = + let offset = start + (i * portion) + remain + in (offset, offset + portion - 1) + +data InclusiveRange = InclusiveRange Int Int +-} diff --git a/Data/LVar/NatArray/Unsafe.hs b/Data/LVar/NatArray/Unsafe.hs new file mode 100644 --- /dev/null +++ b/Data/LVar/NatArray/Unsafe.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE GADTs #-} + +-- | Unsafe operations on NatArray. NOT for end-user applications. + +module Data.LVar.NatArray.Unsafe + ( NatArray(..), unsafePeek ) + where +import qualified Data.Vector.Storable.Mutable as M +import Foreign.Storable (sizeOf, Storable) +-- import System.IO.Unsafe (unsafeDupablePerformIO) +import Control.LVish.Internal as LI + +------------------------------------------------------------------------------------------ + +-- | An array of bit-fields with a monotonic OR operation. This can be used to model +-- a set of Ints by setting the vector entries to zero or one, but it can also +-- model other finite lattices for each index. +-- newtype NatArray s a = NatArray (LVar s (M.IOVector a) (Int,a)) +data NatArray s a = Storable a => NatArray !(LVar s (M.IOVector a) (Int,a)) + +unsafePeek :: (Num a, Eq a) => NatArray s a -> Int -> Par d s (Maybe a) +unsafePeek (NatArray lv) ix = do + peek <- LI.liftIO $ M.read (LI.state lv) ix + case peek of + -- TODO: generalize: + 0 -> return Nothing + x -> return $! Just x diff --git a/Data/LVar/PNCounter.hs b/Data/LVar/PNCounter.hs new file mode 100644 --- /dev/null +++ b/Data/LVar/PNCounter.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE BangPatterns #-} + +{-| + +This module provides a /PN-Counter/, a counter that allows both +increment and decrement operations. This is possible because, under +the hood, it's represented with two monotonically growing counters, +one for increments and one for decrements. The name "PN-Counter" +comes from the literature on /conflict-free replicated data types/. + + -} +module Data.LVar.PNCounter + ( + PNCounter, + newCounter, newCounterWithValue, + increment, waitForIncrements, + decrement, waitForDecrements, + + freezeCounter + + ) where +import Control.LVish +import Control.LVish.Internal +import qualified Data.Atomics.Counter.Reference as AC +-- LK: FIXME: it can't be okay to use SchedIdempotent if we're using bump, can it?! +import Control.LVish.SchedIdempotent (newLV) +import Data.IORef + + +-- | The counter datatype. + +-- LK: LVar around the outside, or PureLVar? What's the difference? +data PNCounter s = LVar s (AC.AtomicCounter, AC.AtomicCounter) + +-- | Create a new `PNCounter` set to zero. +newCounter :: Par d s (PNCounter s) +newCounter = newCounterWithValue 0 + +-- | Create a new `PNCounter` with the specified initial value. +newCounterWithValue :: Int -> Par d s (PNCounter s) +-- LK: hm, how do I create IORefs and then return a Par? I think what +-- I'm supposed to be doing here is wrapping an unsafe internal Par +-- computation (that's allowed to do IO) in a safe one that I return. +newCounterWithValue n = undefined +-- FIXME... + -- do + -- incs <- newIORef (Just n) + -- decs <- newIORef Nothing + +-- | Increment the `PNCounter`. +increment :: PNCounter s -> Par d s () +increment = undefined + +-- | Wait for the number of increments to reach a given number. +waitForIncrements :: Int -> PNCounter s -> Par d s () +waitForIncrements = undefined + +-- | Decrement the `PNCounter`. +decrement :: PNCounter s -> Par d s () +decrement = undefined + +-- | Wait for the number of decrements to reach a given number. +waitForDecrements :: Int -> PNCounter s -> Par d s () +waitForDecrements = undefined + +-- | Get the exact contents of the counter. As with any +-- quasi-deterministic operation, using `freezeCounter` may cause your +-- program to exhibit a limited form of nondeterminism: it will never +-- return the wrong answer, but it may include synchronization bugs +-- that can (nondeterministically) cause exceptions. +freezeCounter :: PNCounter s -> QPar s Int +-- Freezing takes the difference of increments and decrements. +freezeCounter = undefined diff --git a/Data/LVar/PureMap.hs b/Data/LVar/PureMap.hs --- a/Data/LVar/PureMap.hs +++ b/Data/LVar/PureMap.hs @@ -4,11 +4,12 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE MultiParamTypeClasses #-} +-- {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE IncoherentInstances #-} +-- {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} {-| @@ -23,10 +24,13 @@ module Data.LVar.PureMap ( -- * Basic operations - IMap, + IMap(..), newEmptyMap, newMap, newFromList, insert, - getKey, waitValue, waitSize, modify, + getKey, waitValue, waitSize, modify, + + -- * Generic routines and convenient aliases + gmodify, getOrInit, -- * Iteration and callbacks forEach, forEachHP, @@ -34,93 +38,40 @@ -- * Quasi-deterministic operations freezeMap, fromIMap, + traverseFrzn_, -- * Higher-level derived operations copy, traverseMap, traverseMap_, union, -- * Alternate versions of derived ops that expose @HandlerPool@s they create - traverseMapHP, traverseMapHP_, unionHP + traverseMapHP, traverseMapHP_, unionHP ) where -import Control.Monad (void) -import Control.Exception (throw) -import Control.Applicative (Applicative, (<$>),(*>), pure, getConst, Const(Const)) -import Data.Monoid (Monoid(..)) -import Data.IORef -import qualified Data.Map.Strict as M -import qualified Data.LVar.IVar as IV -import qualified Data.Foldable as F -import Data.LVar.Generic -import Data.LVar.Generic.Internal (unsafeCoerceLVar) -import Data.UtilInternal (traverseWithKey_) -import Data.List (intersperse) import Control.LVish.DeepFrz.Internal import Control.LVish import Control.LVish.Internal as LI import Control.LVish.SchedIdempotent (newLV, putLV, putLV_, getLV, freezeLV, freezeLVAfter) import qualified Control.LVish.SchedIdempotent as L +import qualified Data.LVar.IVar as IV +import Data.LVar.Generic as G +import Data.LVar.PureMap.Unsafe +import Data.UtilInternal (traverseWithKey_) + +import Control.Exception (throw) +import Data.IORef +import qualified Data.Map.Strict as M import System.IO.Unsafe (unsafePerformIO, unsafeDupablePerformIO) import System.Mem.StableName (makeStableName, hashStableName) ------------------------------------------------------------------------------- --- IMaps implemented on top of LVars: ------------------------------------------------------------------------------- - --- | The map datatype itself. Like all other LVars, it has an @s@ parameter (think --- `STRef`) in addition to the @a@ parameter that describes the type of elements --- in the set. --- --- Performance note: There is only /one/ mutable location in this implementation. Thus --- it is not a scalable implementation. -newtype IMap k s v = IMap (LVar s (IORef (M.Map k v)) (k,v)) - --- | Equality is physical equality, as with @IORef@s. -instance Eq (IMap k s v) where - IMap lv1 == IMap lv2 = state lv1 == state lv2 - --- | An `IMap` can be treated as a generic container LVar. However, the polymorphic --- operations are less useful than the monomorphic ones exposed by this module. -instance LVarData1 (IMap k) where - freeze orig@(IMap (WrapLVar lv)) = WrapPar$ do freezeLV lv; return (unsafeCoerceLVar orig) - -- Unlike the Map-specific forEach variants, this takes only values, not keys. - addHandler mh mp fn = forEachHP mh mp (\ _k v -> fn v) - sortFrzn (IMap lv) = AFoldable$ unsafeDupablePerformIO (readIORef (state lv)) - --- | The `IMap`s in this module also have the special property that they support an --- /O(1)/ freeze operation which immediately yields a `Foldable` container --- (`snapFreeze`). -instance OrderedLVarData1 (IMap k) where - snapFreeze is = unsafeCoerceLVar <$> freeze is - --- As with all LVars, after freezing, map elements can be consumed. In --- the case of this `IMap` implementation, it need only be `Frzn`, not --- `Trvrsbl`. -instance F.Foldable (IMap k Frzn) where - foldr fn zer (IMap lv) = - let set = unsafeDupablePerformIO (readIORef (state lv)) in - F.foldr fn zer set - --- Of course, the stronger `Trvrsbl` state is still fine for folding. -instance F.Foldable (IMap k Trvrsbl) where - foldr fn zer mp = F.foldr fn zer (castFrzn mp) - --- `IMap` values can be returned as the result of a --- `runParThenFreeze`. Hence they need a `DeepFrz` instance. --- @DeepFrz@ is just a type-coercion. No bits flipped at runtime. -instance DeepFrz a => DeepFrz (IMap k s a) where - type FrzType (IMap k s a) = IMap k Frzn (FrzType a) - frz = unsafeCoerceLVar - -instance (Show k, Show a) => Show (IMap k Frzn a) where - show (IMap lv) = - let mp' = unsafeDupablePerformIO (readIORef (state lv)) in - "{IMap: " ++ - (concat $ intersperse ", " $ map show $ - M.toList mp') ++ "}" +#ifdef GENERIC_PAR +-- From here we get a Generator and, in the future, ParFoldable instance for Map: +import Data.Par.Map () --- | For convenience only; the user could define this. -instance (Show k, Show a) => Show (IMap k Trvrsbl a) where - show lv = show (castFrzn lv) +import qualified Control.Par.Class as PC +import Control.Par.Class.Unsafe (internalLiftIO) +-- import qualified Data.Splittable.Class as Sp +-- import Data.Par.Splittable (pmapReduceWith_, mkMapReduce) +#endif -------------------------------------------------------------------------------- @@ -153,31 +104,16 @@ IV.get res where deltaCB (k,v) = return$ Just$ unWrapPar $ callback k v - initCB :: HandlerPool -> IV.IVar s b -> (IORef (M.Map k v)) -> IO (Maybe (L.Par ())) + initCB :: HandlerPool -> IV.IVar s b -> (IORef (M.Map k v)) -> L.Par () initCB hp resIV ref = do -- The implementation guarantees that all elements will be caught either here, -- or by the delta-callback: - mp <- readIORef ref -- Snapshot - return $ Just $ unWrapPar $ do + mp <- L.liftIO $ readIORef ref -- Snapshot + unWrapPar $ do traverseWithKey_ (\ k v -> forkHP (Just hp)$ callback k v) mp res <- action -- Any additional puts here trigger the callback. IV.put_ resIV res --- | Add an (asynchronous) callback that listens for all new key/value pairs added to --- the map, optionally enrolled in a handler pool. -forEachHP :: Maybe HandlerPool -- ^ optional pool to enroll in - -> IMap k s v -- ^ Map to listen to - -> (k -> v -> Par d s ()) -- ^ callback - -> Par d s () -forEachHP mh (IMap (WrapLVar lv)) callb = WrapPar $ do - L.addHandler mh lv globalCB deltaCB - return () - where - deltaCB (k,v) = return$ Just$ unWrapPar $ callb k v - globalCB ref = do - mp <- readIORef ref -- Snapshot - return $ Just $ unWrapPar $ - traverseWithKey_ (\ k v -> forkHP mh$ callb k v) mp -- | Add an (asynchronous) callback that listens for all new new key/value pairs added to -- the map. @@ -220,23 +156,40 @@ let ref = state lv mp <- L.liftIO$ readIORef ref case M.lookup key mp of - Just lv2 -> do L.logStrLn$ " [Map.modify] key already present: "++show key++ - " adding to inner "++show(unsafeName lv2) + Just lv2 -> do L.logStrLn 3 $ " [Map.modify] key already present: "++show key++ + " adding to inner "++show(unsafeName lv2) unWrapPar$ fn lv2 Nothing -> do bot <- unWrapPar newBottom :: L.Par (f s a) - L.logStrLn$ " [Map.modify] allocated new inner "++show(unsafeName bot) + L.logStrLn 3$ " [Map.modify] allocated new inner "++show(unsafeName bot) let putter _ = L.liftIO$ atomicModifyIORef' ref $ \ mp2 -> case M.lookup key mp2 of Just lv2 -> (mp2, (Nothing, unWrapPar$ fn lv2)) Nothing -> (M.insert key bot mp2, (Just (key, bot), - do L.logStrLn$ " [Map.modify] key absent, adding the new one." + do L.logStrLn 3$ " [Map.modify] key absent, adding the new one." unWrapPar$ fn bot)) - act <- putLV_ (unWrapLVar lv) putter act +{-# INLINE gmodify #-} +-- | A generic version of `modify` that does not require a `newBottom` argument, +-- rather, it uses the generic version of that function. +gmodify :: forall f a b d s key . (Ord key, LVarData1 f, LVarWBottom f, LVContents f a, Show key, Ord a) => + IMap key s (f s a) + -> key -- ^ The key to lookup. + -> (f s a -> Par d s b) -- ^ The computation to apply on the right-hand side of the keyed entry. + -> Par d s b +gmodify map key fn = modify map key G.newBottom fn + +{-# INLINE getOrInit #-} +-- | Return the preexisting value for a key if it exists, and otherwise return +-- +-- This is a convenience routine that can easily be defined in terms of `gmodify` +getOrInit :: forall f a b d s key . (Ord key, LVarData1 f, LVarWBottom f, LVContents f a, Show key, Ord a) => + key -> IMap key s (f s a) -> Par d s (f s a) +getOrInit key mp = gmodify mp key return + -- | Wait for the map to contain a specified key, and return the associated value. getKey :: Ord k => k -> IMap k s v -> Par d s v getKey !key (IMap (WrapLVar lv)) = WrapPar$ getLV lv globalThresh deltaThresh @@ -278,13 +231,13 @@ deltaThresh _ = globalThresh (L.state lv) False -- | Get the exact contents of the map. As with any --- quasi-deterministic operation, using `freezeSet` may cause your +-- quasi-deterministic operation, using `freezeMap` may cause your -- program to exhibit a limited form of nondeterminism: it will never -- return the wrong answer, but it may include synchronization bugs -- that can (nondeterministically) cause exceptions. -- -- This "Data.Map"-based implementation has the special property that --- you can retrieve the full set without any `IO`, and without +-- you can retrieve the full map without any `IO`, and without -- nondeterminism leaking. (This is because the internal order is -- fixed for the tree-based representation of maps that "Data.Map" -- uses.) @@ -303,6 +256,14 @@ fromIMap :: IMap k Frzn a -> M.Map k a fromIMap (IMap lv) = unsafeDupablePerformIO (readIORef (state lv)) +-- | Traverse a frozen map for side effect. This is useful (in comparison with more +-- generic operations) because the function passed in may see the key as well as the +-- value. +traverseFrzn_ :: (Ord k) => + (k -> a -> Par d s ()) -> IMap k Frzn a -> Par d s () +traverseFrzn_ fn mp = + traverseWithKey_ fn (fromIMap mp) + -------------------------------------------------------------------------------- -- Higher level routines that could (mostly) be defined using the above interface. -------------------------------------------------------------------------------- @@ -370,3 +331,25 @@ unsafeName x = unsafePerformIO $ do sn <- makeStableName x return (hashStableName sn) + +-------------------------------------------------------------------------------- +-- Interfaces for generic programming with containers: + +#ifdef GENERIC_PAR +#warning "Creating instances for generic programming with IMaps" +instance PC.Generator (IMap k Frzn a) where + type ElemOf (IMap k Frzn a) = (k,a) + {-# INLINE fold #-} + {-# INLINE foldM #-} + {-# INLINE foldMP #-} + fold fn zer (IMap (WrapLVar lv)) = PC.fold fn zer $ unsafeDupablePerformIO $ readIORef $ L.state lv + foldM fn zer (IMap (WrapLVar lv)) = PC.foldM fn zer $ unsafeDupablePerformIO $ readIORef $ L.state lv + foldMP fn zer (IMap (WrapLVar lv)) = PC.foldMP fn zer $ unsafeDupablePerformIO $ readIORef $ L.state lv + +-- TODO: Once containers 0.5.3.2+ is broadly available we can have a real parFoldable +-- instance. +-- instance Show k => PC.ParFoldable (IMap k Frzn a) where + +#endif + + diff --git a/Data/LVar/PureMap/Unsafe.hs b/Data/LVar/PureMap/Unsafe.hs new file mode 100644 --- /dev/null +++ b/Data/LVar/PureMap/Unsafe.hs @@ -0,0 +1,167 @@ +{-# LANGUAGE Unsafe #-} + +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} + +{-# LANGUAGE ScopedTypeVariables, ConstraintKinds #-} + +module Data.LVar.PureMap.Unsafe + ( + -- * Unsafe operations: + unsafePeekKey, +-- unsafeGetOrInit, unsafeInsertIfAbsent, + + -- * These are here only to reexport downstream: + IMap(..), forEachHP + ) + where + +import Control.LVish.DeepFrz.Internal +import Control.LVish +import Control.LVish.Internal as LI +import Control.LVish.SchedIdempotent (freezeLV) +import qualified Control.LVish.SchedIdempotent as L +import Data.LVar.Generic as G +import Data.LVar.Generic.Internal (unsafeCoerceLVar) +import Data.UtilInternal (traverseWithKey_) + +import Control.Applicative ((<$>)) +import Data.IORef +import qualified Data.Foldable as F +import qualified Data.Map.Strict as M +import Data.List (intersperse) +import System.IO.Unsafe (unsafeDupablePerformIO) + + +------------------------------------------------------------------------------ +-- IMaps implemented on top of LVars: +------------------------------------------------------------------------------ + +-- | The map datatype itself. Like all other LVars, it has an @s@ parameter (think +-- `STRef`) in addition to the @a@ parameter that describes the type of elements +-- in the set. +-- +-- Performance note: There is only /one/ mutable location in this implementation. Thus +-- it is not a scalable implementation. +newtype IMap k s v = IMap (LVar s (IORef (M.Map k v)) (k,v)) + +-- | Equality is physical equality, as with @IORef@s. +instance Eq (IMap k s v) where + IMap lv1 == IMap lv2 = state lv1 == state lv2 + +-- | An `IMap` can be treated as a generic container LVar. However, the polymorphic +-- operations are less useful than the monomorphic ones exposed by this module. +instance LVarData1 (IMap k) where + freeze orig@(IMap (WrapLVar lv)) = WrapPar$ do freezeLV lv; return (unsafeCoerceLVar orig) + -- Unlike the Map-specific forEach variants, this takes only values, not keys. + addHandler mh mp fn = forEachHP mh mp (\ _k v -> fn v) + sortFrzn (IMap lv) = AFoldable$ unsafeDupablePerformIO (readIORef (state lv)) + +-- | The `IMap`s in this module also have the special property that they support an +-- /O(1)/ freeze operation which immediately yields a `Foldable` container +-- (`snapFreeze`). +instance OrderedLVarData1 (IMap k) where + snapFreeze is = unsafeCoerceLVar <$> freeze is + +-- As with all LVars, after freezing, map elements can be consumed. In +-- the case of this `IMap` implementation, it need only be `Frzn`, not +-- `Trvrsbl`. +instance F.Foldable (IMap k Frzn) where + foldr fn zer (IMap lv) = + let set = unsafeDupablePerformIO (readIORef (state lv)) in + F.foldr fn zer set + +-- Of course, the stronger `Trvrsbl` state is still fine for folding. +instance F.Foldable (IMap k Trvrsbl) where + foldr fn zer mp = F.foldr fn zer (castFrzn mp) + +-- `IMap` values can be returned as the result of a +-- `runParThenFreeze`. Hence they need a `DeepFrz` instance. +-- @DeepFrz@ is just a type-coercion. No bits flipped at runtime. +instance DeepFrz a => DeepFrz (IMap k s a) where + type FrzType (IMap k s a) = IMap k Frzn (FrzType a) + frz = unsafeCoerceLVar + +instance (Show k, Show a) => Show (IMap k Frzn a) where + show (IMap lv) = + let mp' = unsafeDupablePerformIO (readIORef (state lv)) in + "{IMap: " ++ + (concat $ intersperse ", " $ map show $ + M.toList mp') ++ "}" + +-- | For convenience only; the user could define this. +instance (Show k, Show a) => Show (IMap k Trvrsbl a) where + show lv = show (castFrzn lv) + + +-- | Add an (asynchronous) callback that listens for all new key/value pairs added to +-- the map, optionally enrolled in a handler pool. +forEachHP :: Maybe HandlerPool -- ^ optional pool to enroll in + -> IMap k s v -- ^ Map to listen to + -> (k -> v -> Par d s ()) -- ^ callback + -> Par d s () +forEachHP mh (IMap (WrapLVar lv)) callb = WrapPar $ do + L.addHandler mh lv globalCB deltaCB + return () + where + deltaCB (k,v) = return$ Just$ unWrapPar $ callb k v + globalCB ref = do + mp <- L.liftIO $ readIORef ref -- Snapshot + unWrapPar $ + traverseWithKey_ (\ k v -> forkHP mh$ callb k v) mp + +------------------------------------------------------------------------------ + + +-- | An unsafe, nonblocking version of `getKey`. This reveals whether +unsafePeekKey :: Ord k => k -> IMap k s v -> Par d s (Maybe v) +unsafePeekKey key (IMap (WrapLVar lv)) = do + mp <- liftIO$ readIORef (L.state lv) + return$! M.lookup key mp + +-- | A generic initialize proceedure that returns a preexisting value, if it exists, +-- otherwise filling in a new "bottom" value and returning it. +-- +-- The boolean return value is @True@ iff a new, fresh entry was created. +unsafeGetOrInit :: forall f a b d s key . (Ord key, LVarWBottom f, LVContents f a, Show key, Ord a) => + key -- ^ The key to lookup or populate. + -> IMap key s (f s a) + -> Par d s (Bool, f s a) +unsafeGetOrInit key (IMap (WrapLVar lv)) = go1 + where + -- go1 is OPTIONAL optimization. Could skip right to go2. + -- The tension here is that we can't do IO during an atomicModifyIORef. + go1 = do + let mpref = (L.state lv) + mp <- liftIO$ readIORef mpref + case M.lookup key mp of + Just x -> return (False,x) + Nothing -> go2 + go2 = do + bot <- G.newBottom + liftIO$ atomicModifyIORef' (L.state lv) $ \ mp -> + -- Here we pay the cost of a SECOND lookup. Ouch! + case M.lookup key mp of + Nothing -> (M.insert key bot mp,(True,bot)) + -- Oops! it appeared in the meantime. Our allocation was still wasted: + Just x -> (mp,(False,x)) + +-- FIXME: need a delta-thresh! +-- act <- putLV_ (unWrapLVar lv) putter + + +{- + +-- | An unsafe way to race to insert. Returns Nothing if the insert is successful, +-- and the found value otherwise. +unsafeInsertIfAbsent :: Ord k => k -> v -> IMap k s v -> Par d s (Maybe v)a +unsafeInsertIfAbsent key val (IMap (WrapLVar lv)) = liftIO$ + atomicModifyIORef' (L.state lv) $ \ mp -> + case M.lookup key mp of + Nothing -> (M.insert key val mp,Nothing) + -- Oops! it appeared in the meantime. Our allocation was still wasted: + x@(Just _) -> (mp,x) + +-- FIXME: need a delta-thresh! +-- act <- putLV_ (unWrapLVar lv) putter +-} diff --git a/Data/LVar/PureSet.hs b/Data/LVar/PureSet.hs --- a/Data/LVar/PureSet.hs +++ b/Data/LVar/PureSet.hs @@ -24,7 +24,7 @@ module Data.LVar.PureSet ( -- * Basic operations - ISet, + ISet(..), newEmptySet, newSet, newFromList, insert, waitElem, waitSize, @@ -61,6 +61,9 @@ import System.IO.Unsafe (unsafeDupablePerformIO) import Prelude hiding (insert) +-- LK: Why is it ok to just write WrapPar and LVar instead of LI.WrapPar +-- and LI.LVar? Where are they being imported from? + ------------------------------------------------------------------------------ -- ISets and setmap implemented on top of LVars: ------------------------------------------------------------------------------ @@ -163,14 +166,14 @@ IV.get res where deltCB x = return$ Just$ unWrapPar$ callback x - initCB hp resIV ref = do + initCB hp resIV ref = (do -- The implementation guarantees that all elements will be caught either here, -- or by the delta-callback: - set <- readIORef ref -- Snapshot - return $ Just $ unWrapPar $ do + set <- L.liftIO $ readIORef ref -- Snapshot + unWrapPar $ do F.foldlM (\() v -> forkHP (Just hp)$ callback v) () set -- Non-allocating traversal. res <- action -- Any additional puts here trigger the callback. - IV.put_ resIV res + IV.put_ resIV res) :: L.Par () -- | Get the exact contents of the set. As with any -- quasi-deterministic operation, using `freezeSet` may cause your @@ -213,8 +216,8 @@ return () where globalCB ref = do - set <- readIORef ref -- Snapshot - return $ Just $ unWrapPar $ + set <- L.liftIO$ readIORef ref -- Snapshot + unWrapPar $ F.foldlM (\() v -> forkHP hp $ callb v) () set -- Non-allocating traversal. -- | Add an (asynchronous) callback that listens for all new elements added to @@ -261,7 +264,7 @@ True -> return (Just ()) False -> return (Nothing) -- Here's an example of a situation where we CANNOT TELL if a delta puts it over - -- the threshold.a + -- the threshold. deltaThresh _ = globalThresh (state lv) False -------------------------------------------------------------------------------- @@ -391,6 +394,6 @@ peeksR <- liftIO$ mapM (readIORef . state . unISet) right -- F.foldlM (\() elm2 -> insert (cmbn elm1 elm2) outSet) () peek - return undefined + (error "FINISHME - pure set cartesianProdHP") #endif diff --git a/Data/LVar/SLMap.hs b/Data/LVar/SLMap.hs --- a/Data/LVar/SLMap.hs +++ b/Data/LVar/SLMap.hs @@ -31,11 +31,12 @@ IMap, newEmptyMap, newMap, newFromList, insert, - getKey, waitSize, modify, + getKey, waitSize, waitValue, + modify, -- * Quasi-deterministic operations freezeMap, - -- waitValue, + traverseFrzn_, -- * Iteration and callbacks forEach, forEachHP, @@ -47,6 +48,8 @@ -- * Alternate versions of derived ops that expose @HandlerPool@s they create traverseMapHP, traverseMapHP_, unionHP, + -- * Debugging Helpers + levelCounts ) where import Control.Exception (throw) @@ -71,6 +74,15 @@ import GHC.Prim (unsafeCoerce#) import Prelude +import Debug.Trace + +#ifdef GENERIC_PAR +import qualified Control.Par.Class as PC +import Control.Par.Class.Unsafe (internalLiftIO) +import qualified Data.Splittable.Class as Sp +import Data.Par.Splittable (pmapReduceWith_, mkMapReduce) +#endif + ------------------------------------------------------------------------------ -- IMaps implemented vis SkipListMap ------------------------------------------------------------------------------ @@ -108,8 +120,9 @@ L.addHandler mh lv globalCB (\(_k,v) -> return$ Just$ unWrapPar$ callb v) where globalCB slm = - return $ Just $ unWrapPar $ - SLM.foldlWithKey (\() _k v -> forkHP mh $ callb v) () slm + unWrapPar $ + SLM.foldlWithKey LI.liftIO + (\() _k v -> forkHP mh $ callb v) () slm -- | The `IMap`s in this module also have the special property that they support an -- /O(1)/ freeze operation which immediately yields a `Foldable` container @@ -124,6 +137,7 @@ type FrzType (IMap k s a) = IMap k Frzn (FrzType a) frz = unsafeCoerceLVar + -------------------------------------------------------------------------------- -- | The default number of skiplist levels @@ -159,6 +173,7 @@ newFromList_ :: Ord k => [(k,v)] -> Int -> Par d s (IMap k s v) newFromList_ ls n = do m@(IMap lv) <- newEmptyMap_ n + -- TODO: May want to consider parallelism here for sufficiently large inputs: forM_ ls $ \(k,v) -> LI.liftIO $ SLM.putIfAbsent (state lv) k $ return v return m @@ -174,8 +189,9 @@ initCB slm = do -- The implementation guarantees that all elements will be caught either here, -- or by the delta-callback: - return $ Just $ unWrapPar $ do - SLM.foldlWithKey (\() k v -> forkHP (Just hp) $ callback k v) () slm + unWrapPar $ do + SLM.foldlWithKey LI.liftIO + (\() k v -> forkHP (Just hp) $ callback k v) () slm x <- action -- Any additional puts here trigger the callback. IV.put_ res x WrapPar $ L.addHandler (Just hp) (unWrapLVar lv) initCB deltCB @@ -194,9 +210,13 @@ forEachHP mh (IMap (WrapLVar lv)) callb = WrapPar $ L.addHandler mh lv globalCB (\(k,v) -> return$ Just$ unWrapPar$ callb k v) where - globalCB slm = - return $ Just $ unWrapPar $ - SLM.foldlWithKey (\() k v -> forkHP mh $ callb k v) () slm + gcallb k v = do + logDbgLn 5 " [SLMap] callback from global traversal " + callb k v + globalCB slm = do + unWrapPar $ do + logDbgLn 5 " [SLMap] Beginning fold to check for global-work" + SLM.foldlWithKey LI.liftIO (\() k v -> forkHP mh $ gcallb k v) () slm -- | Add an (asynchronous) callback that listens for all new new key/value pairs added to -- the map. @@ -243,7 +263,18 @@ -- | Wait until the map contains a certain value (on any key). waitValue :: (Ord k, Eq v) => v -> IMap k s v -> Par d s () -waitValue !val (IMap (WrapLVar lv)) = error "TODO / FINISHME SLMap.waitValue" +waitValue !val (IMap (WrapLVar lv)) = WrapPar$ getLV lv globalThresh deltaThresh + where + deltaThresh (_,v) | v == val = return$ Just () + | otherwise = return Nothing + globalThresh ref _frzn = do + let slm = L.state lv + let fn Nothing _k v | v == val = return $! Just () + | otherwise = return $ Nothing + fn just _ _ = return $! just + -- This is inefficient. + -- FIXME: no short-circuit for this fold: + SLM.foldlWithKey id fn Nothing slm -- | Wait on the SIZE of the map, not its contents. waitSize :: Int -> IMap k s v -> Par d s () @@ -251,7 +282,7 @@ getLV lv globalThresh deltaThresh where globalThresh slm _ = do - snapSize <- SLM.foldlWithKey (\n _ _ -> return $ n+1) 0 slm + snapSize <- SLM.foldlWithKey id (\n _ _ -> return $ n+1) 0 slm case snapSize >= sz of True -> return (Just ()) False -> return (Nothing) @@ -277,6 +308,17 @@ -- the freezeLV part.... return (unsafeCoerce# x) + +-- | Traverse a frozen map for side effect. This is useful (in comparison with more +-- generic operations) because the function passed in may see the key as well as the +-- value. +traverseFrzn_ :: (Ord k) => + (k -> a -> Par d s ()) -> IMap k Frzn a -> Par d s () +traverseFrzn_ fn (IMap (WrapLVar lv)) = + SLM.foldlWithKey LI.liftIO + (\ () k v -> fn k v) + () (L.state lv) + -------------------------------------------------------------------------------- -- Higher level routines that could (mostly) be defined using the above interface. -------------------------------------------------------------------------------- @@ -331,6 +373,11 @@ forEachHP mh m2 (\ k v -> insert k v os) return os +levelCounts :: IMap k s a -> IO [Int] +levelCounts (IMap (WrapLVar lv)) = + let slm = L.state lv in + SLM.counts slm + -------------------------------------------------------------------------------- -- Operations on frozen Maps -------------------------------------------------------------------------------- @@ -341,24 +388,84 @@ instance F.Foldable (IMap k Frzn) where -- Note: making these strict for now: foldr fn zer (IMap (WrapLVar lv)) = + -- TODO: this isn't a fold RIGHT, it's a fold left. Need to fix that: unsafeDupablePerformIO $ - SLM.foldlWithKey (\ a _k v -> return (fn v a)) + SLM.foldlWithKey id (\ a _k v -> return (fn v a)) zer (L.state lv) -- Of course, the stronger `Trvrsbl` state is still fine for folding. instance F.Foldable (IMap k Trvrsbl) where foldr fn zer mp = F.foldr fn zer (castFrzn mp) +#ifdef GENERIC_PAR +#warning "Creating instances for generic programming with IMaps" +instance PC.Generator (IMap k Frzn a) where + type ElemOf (IMap k Frzn a) = (k,a) + {-# INLINE fold #-} + fold fn zer (IMap (WrapLVar lv)) = + unsafeDupablePerformIO $ + SLM.foldlWithKey id (\ a k v -> return $! fn a (k,v)) + zer (L.state lv) + + {-# INLINE foldMP #-} + -- | More efficient, not requiring unsafePerformIO or risk of duplication. + foldMP fn zer (IMap (WrapLVar lv)) = + SLM.foldlWithKey internalLiftIO (\ a k v -> fn a (k,v)) + zer (L.state lv) + + +instance Show k => PC.ParFoldable (IMap k Frzn a) where + {-# INLINE pmapFold #-} + -- Can't split directly but can slice and then split: + pmapFold mfn rfn initAcc (IMap lv) = do + let slm = state lv + slc = SLM.toSlice slm + -- Is it worth using unsafeDupablePerformIO here? Or is the granularity large + -- enough that we might as well use unsafePerformIO? + splitter s = + -- Some unfortunate conversion between protocols: + case unsafeDupablePerformIO (SLM.splitSlice s) of + Nothing -> [s] + Just (s1,s2) -> [s1,s2] + + -- Ideally we could liftIO into the Par monad here. + seqfold fn zer (SLM.Slice slm st en) = do + internalLiftIO $ putStrLn $ "[DBG] dropping to seqfold.., st/en: "++show (st,en) + -- FIXME: Fold over only the range in the slice: + SLM.foldlWithKey internalLiftIO (\ a k v -> fn a (k,v)) zer slm + internalLiftIO $ putStrLn$ "[DBG] pmapFold on frzn IMap... calling mkMapReduce" + mkMapReduce splitter seqfold PC.spawn_ + slc mfn rfn initAcc + +-- UNSAFE! It is naughty if this instance escapes to the outside world, which it can... +instance F.Foldable (SLMapSlice k) where +#endif + instance (Show k, Show a) => Show (IMap k Frzn a) where show (IMap (WrapLVar lv)) = "{IMap: " ++ (concat $ intersperse ", " $ unsafeDupablePerformIO $ - SLM.foldlWithKey (\ acc k v -> return$ show (k, v) : acc) + SLM.foldlWithKey id (\ acc k v -> return$ show (k, v) : acc) [] (L.state lv) ) ++ "}" -- | For convenience only; the user could define this. instance (Show k, Show a) => Show (IMap k Trvrsbl a) where show lv = show (castFrzn lv) + + +-------------------------------------------------------------------------------- + +-- #ifdef GENERIC_PAR +-- Not exported yet: +#if 0 +instance PC.ParIMap (Par d s) where + type PC.IMap (Par d s) k = IMap k s + type PC.IMapContents (Par d s) k v = (Ord k, Eq v) + PC.waitSize = waitSize + PC.newEmptyMap = newEmptyMap + PC.insert = insert + PC.getKey = getKey +#endif diff --git a/Data/LVar/SLMap/Unsafe.hs b/Data/LVar/SLMap/Unsafe.hs new file mode 100644 --- /dev/null +++ b/Data/LVar/SLMap/Unsafe.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE Unsafe #-} + +module Data.LVar.SLMap.Unsafe + where + +import qualified Data.Concurrent.SkipListMap as SLM + +-- mp <- liftIO$ SLM.find (L.state lv) key + diff --git a/Data/LVar/SLSet.hs b/Data/LVar/SLSet.hs --- a/Data/LVar/SLSet.hs +++ b/Data/LVar/SLSet.hs @@ -131,8 +131,8 @@ instance F.Foldable (ISet Frzn) where foldr fn zer (ISet (WrapLVar lv)) = unsafeDupablePerformIO $ - SLM.foldlWithKey (\ a k _v -> return (fn k a)) - zer (L.state lv) + SLM.foldlWithKey id (\ a k _v -> return (fn k a)) + zer (L.state lv) -- Of course, the stronger `Trvrsbl` state is still fine for folding. instance F.Foldable (ISet Trvrsbl) where @@ -198,11 +198,12 @@ hp <- newPool res <- IV.new -- TODO, specialize to skip this when the init action returns () let deltCB x = return$ Just$ unWrapPar$ callback x - initCB slm = do + initCB slm = -- The implementation guarantees that all elements will be caught either here, -- or by the delta-callback: - return $ Just $ unWrapPar $ do - SLM.foldlWithKey (\() v () -> forkHP (Just hp) $ callback v) () slm + unWrapPar $ do + SLM.foldlWithKey LI.liftIO + (\() v () -> forkHP (Just hp) $ callback v) () slm x <- action -- Any additional puts here trigger the callback. IV.put_ res x WrapPar $ L.addHandler (Just hp) (unWrapLVar lv) initCB deltCB @@ -225,8 +226,9 @@ L.addHandler hp lv globalCB (\x -> return$ Just$ unWrapPar$ callb x) where globalCB slm = - return $ Just $ unWrapPar $ - SLM.foldlWithKey (\() v () -> forkHP hp $ callb v) () slm + unWrapPar $ + SLM.foldlWithKey LI.liftIO + (\() v () -> forkHP hp $ callb v) () slm -- | Add an (asynchronous) callback that listens for all new elements added to -- the set. @@ -258,7 +260,7 @@ getLV lv globalThresh deltaThresh where globalThresh slm _ = do - snapSize <- SLM.foldlWithKey (\n _ _ -> return $ n+1) 0 slm + snapSize <- SLM.foldlWithKey id (\n _ _ -> return $ n+1) 0 slm case snapSize >= sz of True -> return (Just ()) False -> return (Nothing) @@ -360,7 +362,8 @@ where -- This is expensive, but we've got to do it from both sides to counteract races: fn outSet other@(ISet lv) cmbn elm1 = - SLM.foldlWithKey (\() elm2 () -> insert (cmbn elm1 elm2) outSet) () (state lv) + SLM.foldlWithKey LI.liftIO + (\() elm2 () -> insert (cmbn elm1 elm2) outSet) () (state lv) -- | Variant of 'cartesianProds' that optionally ties the handlers to a pool. cartesianProdsHP :: Ord a => Maybe HandlerPool -> [ISet s a] -> @@ -392,6 +395,6 @@ peeksR <- liftIO$ mapM (readIORef . state . unISet) right -- F.foldlM (\() elm2 -> insert (cmbn elm1 elm2) outSet) () peek - return undefined + return (error "FINISHME: set cartesianProdHP") #endif diff --git a/Data/UtilInternal.hs b/Data/UtilInternal.hs --- a/Data/UtilInternal.hs +++ b/Data/UtilInternal.hs @@ -3,14 +3,15 @@ module Data.UtilInternal ( - traverseWithKey_ + traverseWithKey_, + Traverse_(..) ) where import Control.Applicative import Control.Monad (void) import Data.Monoid (Monoid(..)) -import Data.Map as M +import qualified Data.Map as M -------------------------------------------------------------------------------- -- Helper code. @@ -26,9 +27,13 @@ Traverse_ a `mappend` Traverse_ b = Traverse_ (a *> b) -- Since the Applicative used is Const (newtype Const m a = Const m), the -- structure is never built up. ---(b) You can derive traverseWithKey_ from foldMapWithKey, e.g. as follows: +--(b) You can derive traverseWithKey_ from myfoldMapWithKey, e.g. as follows: + +{-# INLINE traverseWithKey_ #-} traverseWithKey_ :: Applicative f => (k -> a -> f ()) -> M.Map k a -> f () traverseWithKey_ f = runTraverse_ . - foldMapWithKey (\k x -> Traverse_ (void (f k x))) -foldMapWithKey :: Monoid r => (k -> a -> r) -> M.Map k a -> r -foldMapWithKey f = getConst . M.traverseWithKey (\k x -> Const (f k x)) + myfoldMapWithKey (\k x -> Traverse_ (void (f k x))) + +{-# INLINE myfoldMapWithKey #-} +myfoldMapWithKey :: Monoid r => (k -> a -> r) -> M.Map k a -> r +myfoldMapWithKey f = getConst . M.traverseWithKey (\k x -> Const (f k x)) diff --git a/TestHelpers.hs b/TestHelpers.hs deleted file mode 100644 --- a/TestHelpers.hs +++ /dev/null @@ -1,186 +0,0 @@ -{-# LANGUAGE BangPatterns, CPP #-} - --- | To make it easier to build (multithreaded) tests - -module TestHelpers - ( - -- * Testing parameters - numElems, getNumAgents, producerRatio, - - -- * Utility for controlling the number of threads used by generated tests. - setTestThreads, - - -- * Test initialization, reading common configs - stdTestHarness - ) - where - -import Data.IORef -import Control.Monad -import qualified Data.Set as S -import Text.Printf -import Control.Concurrent (forkOS, forkIO, ThreadId) --- import Control.Exception (catch, SomeException, fromException, bracket, AsyncException(ThreadKilled)) -import Control.Exception (bracket) -import System.Environment (withArgs, getArgs, getEnvironment) -import System.IO (hFlush, stdout) -import System.IO.Unsafe (unsafePerformIO) -import qualified Test.Framework as TF -import Test.Framework.Providers.HUnit (hUnitTestToTests) -import Test.HUnit as HU - -import Debug.Trace (trace) - --------------------------------------------------------------------------------- - - -#if __GLASGOW_HASKELL__ >= 704 -import GHC.Conc (getNumCapabilities, setNumCapabilities, getNumProcessors) -#else -import GHC.Conc (numCapabilities) -getNumCapabilities :: IO Int -getNumCapabilities = return numCapabilities - -setNumCapabilities :: Int -> IO () -setNumCapabilities = error "setNumCapabilities not supported in this older GHC! Set NUMTHREADS and +RTS -N to match." - -getNumProcessors :: IO Int -getNumProcessors = return 1 -#endif - -theEnv :: [(String, String)] -theEnv = unsafePerformIO getEnvironment - ----------------------------------------------------------------------------------------------------- --- TODO: In addition to setting these parameters from environment --- variables, it would be nice to route all of this through a --- configuration record, so that it can be changed programmatically. - --- How many elements should each of the tests pump through the queue(s)? -numElems :: Int -numElems = case lookup "NUMELEMS" theEnv of - Nothing -> 100 * 1000 -- 500000 - Just str -> warnUsing ("NUMELEMS = "++str) $ - read str - -forkThread :: IO () -> IO ThreadId -forkThread = case lookup "OSTHREADS" theEnv of - Nothing -> forkIO - Just x -> warnUsing ("OSTHREADS = "++x) $ - case x of - "0" -> forkIO - "False" -> forkIO - "1" -> forkOS - "True" -> forkOS - oth -> error$"OSTHREAD environment variable set to unrecognized option: "++oth - --- | How many communicating agents are there? By default one per --- thread used by the RTS. -getNumAgents :: IO Int -getNumAgents = case lookup "NUMAGENTS" theEnv of - Nothing -> getNumCapabilities - Just str -> warnUsing ("NUMAGENTS = "++str) $ - return (read str) - --- | It is possible to have imbalanced concurrency where there is more --- contention on the producing or consuming side (which corresponds to --- settings of this parameter less than or greater than 1). -producerRatio :: Double -producerRatio = case lookup "PRODUCERRATIO" theEnv of - Nothing -> 1.0 - Just str -> warnUsing ("PRODUCERRATIO = "++str) $ - read str - -warnUsing :: String -> a -> a -warnUsing str a = trace (" [Warning]: Using environment variable "++str) a - - --- | Dig through the test constructors to find the leaf IO actions and bracket them --- with a thread-setting action. -setTestThreads :: Int -> HU.Test -> HU.Test -setTestThreads nm tst = loop False tst - where - loop flg x = - case x of - TestLabel lb t2 -> TestLabel (decor flg lb) (loop True t2) - TestList ls -> TestList (map (loop flg) ls) - TestCase io -> TestCase (bracketThreads nm io) - - -- We only need to insert the numcapabilities in the description string ONCE: - decor False lb = "N"++show nm++"_"++ lb - decor True lb = lb - - bracketThreads :: Int -> IO a -> IO a - bracketThreads n act = - bracket (getNumCapabilities) - setNumCapabilities - (\_ -> do dbgPrint 1 ("\n [Setting # capabilities to "++show n++" before test] \n") - setNumCapabilities n - act) - --- | Repeat a group of tests while varying the number of OS threads used. Also, --- read configuration info. --- --- WARNING: uses setNumCapabilities. -stdTestHarness :: (IO Test) -> IO () -stdTestHarness genTests = do - numAgents <- getNumAgents - putStrLn$ "Running with numElems "++show numElems++" and numAgents "++ show numAgents - putStrLn "Use NUMELEMS, NUMAGENTS, NUMTHREADS to control the size of this benchmark." - args <- getArgs - - np <- getNumProcessors - putStrLn $"Running on a machine with "++show np++" hardware threads." - - -- We allow the user to set this directly, because the "-t" based regexp selection - -- of benchmarks is quite limited. - let all_threads = case lookup "NUMTHREADS" theEnv of - Just str -> [read str] - Nothing -> S.toList$ S.fromList$ - [1, 2, np `quot` 2, np, 2*np ] - putStrLn $"Running tests for these thread settings: " ++show all_threads - all_tests <- genTests - - -- Don't allow concurent tests (the tests are concurrent!): - withArgs (args ++ ["-j1","--jxml=test-results.xml"]) $ do - - -- Hack, this shouldn't be necessary, but I'm having problems with -t: - tests <- case all_threads of - [one] -> do cap <- getNumCapabilities - unless (cap == one) $ setNumCapabilities one - return all_tests - _ -> return$ TestList [ setTestThreads n all_tests | n <- all_threads ] - TF.defaultMain$ hUnitTestToTests tests - ----------------------------------------------------------------------------------------------------- --- DEBUGGING ----------------------------------------------------------------------------------------------------- - --- | Debugging flag shared by all accelerate-backend-kit modules. --- This is activated by setting the environment variable DEBUG=1..5 -dbg :: Int -dbg = case lookup "DEBUG" theEnv of - Nothing -> defaultDbg - Just "" -> defaultDbg - Just "0" -> defaultDbg - Just s -> - trace (" ! Responding to env Var: DEBUG="++s)$ - case reads s of - ((n,_):_) -> n - [] -> error$"Attempt to parse DEBUG env var as Int failed: "++show s - -defaultDbg :: Int -defaultDbg = 0 - --- | Print if the debug level is at or above a threshold. -dbgPrint :: Int -> String -> IO () -dbgPrint lvl str = if dbg < lvl then return () else do --- hPutStrLn stderr str - -- hPrintf stderr str - -- hFlush stderr - printf str - hFlush stdout - -dbgPrintLn :: Int -> String -> IO () -dbgPrintLn lvl str = dbgPrint lvl (str++"\n") - diff --git a/lvish.cabal b/lvish.cabal --- a/lvish.cabal +++ b/lvish.cabal @@ -10,7 +10,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 1.0.0.6 +version: 1.1.1.1 -- Changelog: -- 0.2 -- switch SLMap over to O(1) freeze @@ -18,6 +18,10 @@ -- 1.0.0.2 -- minor docs polishing -- 1.0.0.4 -- Bugfix for runParThenFreeze 's' param (issue #26). -- 1.0.0.6 -- tighten up dependencies; remove unused flags; very minor doc fixes. +-- 1.1.0.2 -- add verifyFiniteJoin +-- 1.1.0.3 -- expose BulkRetry prototype +-- 1.1.1.0 -- expose logging routines +-- 1.1.1.1 -- restrict exports for interm hackage release synopsis: Parallel scheduler, LVar data structures, and infrastructure to build more. @@ -49,26 +53,39 @@ cabal-version: >=1.8 flag debug - description: Activate additional debug assertions, and printed output - if DEBUGLVL env var is set to 1 or higher. + description: Activate additional debug assertions, and printed output. +-- if DEBUGLVL env var is set to 1 or higher. default: False flag chaselev description: Use the Chase-Lev work-stealing deque - default: True + default: False +flag newcontainers + description: Use a pre-release version of containers to enable splitting. + default: False + flag getonce description: Ensure that continuations of get run at most once (by using extra synchronization) default: False +-- We won't really support this until LVish 2.0: +flag generic + description: Use (forthcoming) generic interfaces for Par monads. + default: False + +flag beta + description: These features are in beta and not fully supported yet. + default: False + -------------------------------------------------------------------------------- library Source-repository head type: git location: https://github.com/iu-parfunc/lvars subdir: haskell/lvish - tag: release-lvish-1.0.0.6 +-- tag: release-lvish-1.0.0.6 -- Modules exported by the library. exposed-modules: @@ -83,14 +100,37 @@ Data.LVar.SLSet Data.LVar.SLMap ------------------------------------------- + -- Unsafe, only for debugging: + Control.LVish.Unsafe + ------------------------------------------- -- End users should NOT USE THESE. -- These are only for developing new LVars: Data.LVar.Internal.Pure Data.LVar.Generic.Internal - Control.LVish.SchedIdempotent Control.LVish.Internal - Control.LVish.DeepFrz.Internal - + Control.LVish.DeepFrz.Internal + -- This is also not recommended for general use yet. + Data.Concurrent.SkipListMap + if flag(beta) + exposed-modules: + -- Not quite ready for prime-time yet: + Data.LVar.NatArray + Data.LVar.NatArray.Unsafe + Data.LVar.MaxCounter + Data.LVar.AddRemoveSet + Data.LVar.PNCounter + ------------------------------------------- + -- New / Experimental: + Data.LVar.Memo + Data.LVar.CycGraph + + Data.LVar.PureMap.Unsafe + Data.LVar.SLMap.Unsafe + + if flag(beta) && flag(newcontainers) + exposed-modules: + Control.LVish.BulkRetry + -- Modules included in this library but not exported. other-modules: Data.UtilInternal @@ -99,32 +139,43 @@ Data.Concurrent.Counter Data.Concurrent.SNZI Data.Concurrent.LinkedMap - Data.Concurrent.SkipListMap Data.Concurrent.AlignedIORef Control.Reagent + Control.LVish.SchedIdempotent Control.LVish.SchedIdempotentInternal Control.LVish.MonadToss Control.LVish.Types - -- Not ready for prime-time yet: --- Data.LVar.NatArray - Data.LVar.MaxCounter + Control.LVish.Basics + Control.LVish.Logical + Control.LVish.Logging -- Other library packages from which modules are imported. build-depends: base >= 4.6 && <= 4.8, deepseq >= 1.3, - containers >= 0.5, lattices >= 1.2, vector >=0.10, atomic-primops >= 0.4, random, transformers, - ghc-prim + ghc-prim, + async, -- Used in NatArray: --- bits-atomic, missing-foreign + bits-atomic, missing-foreign + if flag(newcontainers) { build-depends: containers >= 0.5.3.2 } + else { build-depends: containers >= 0.5 } + if flag(generic) + cpp-options: -DGENERIC_PAR + build-depends: par-classes >= 1.0 && < 2.0, + par-collections >= 1.0 && < 2.0 +-- par-transformers <= 2.0 ghc-options: -O2 -rtsopts + if flag(debug) + -- TEMP: depending on these for visualzing MemoCyc DAGs: + build-depends: fgl, graphviz, text cpp-options: -DDEBUG_LVAR + cpp-options: -DDEBUG_MEMO if flag(chaselev) build-depends: chaselev-deque cpp-options: -DCHASE_LEV @@ -133,15 +184,25 @@ -------------------------------------------------------------------------------- --- TODO: New tests here: + test-suite test-lvish type: exitcode-stdio-1.0 - main-is: unit-tests.hs - other-modules: TestHelpers - - ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-N4 + main-is: Main.hs + hs-source-dirs: tests/ ./ + other-modules: TestHelpers, + LVishAndIVar, + ArrayTests, + MemoTests, + LogicalTests, + PureMapTests, + SLMapTests, + SetTests, + MaxCounterTests + +-- ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-N4 + ghc-options: -O2 -rtsopts - -- DUPLICATE: + -- DUPLICATED: from above build-depends: base >= 4.6 && <= 4.8, deepseq >= 1.3, containers >= 0.5, @@ -150,11 +211,29 @@ atomic-primops >= 0.4, random, transformers, - ghc-prim - - build-depends: time, HUnit, test-framework, test-framework-hunit, test-framework-th + ghc-prim, + async, + -- Used in NatArray: + bits-atomic, missing-foreign + if flag(generic) + cpp-options: -DGENERIC_PAR + build-depends: par-classes >= 1.0 && < 2.0, + par-collections >= 1.0 && < 2.0 + -- END DUPLICATED + if flag(generic) + other-modules: GenericTests + + build-depends: test-framework, test-framework-hunit, test-framework-th, + test-framework-quickcheck2, QuickCheck, + HUnit, time, text +-- And the self-dependency: TODO -- how to get this to work? [2013.10.10] +-- For now it gets compiled TWICE: + build-depends: lvish if flag(debug) + -- TEMP: depending on these for visualzing MemoCyc DAGs: + build-depends: fgl, graphviz, text cpp-options: -DDEBUG_LVAR + cpp-options: -DDEBUG_MEMO if flag(chaselev) build-depends: chaselev-deque cpp-options: -DCHASE_LEV diff --git a/tests/ArrayTests.hs b/tests/ArrayTests.hs new file mode 100644 --- /dev/null +++ b/tests/ArrayTests.hs @@ -0,0 +1,256 @@ + +-- | Various kinds of IStructures or arrays of IVars. + +{-# LANGUAGE TemplateHaskell, CPP, ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE NamedFieldPuns #-} + +module ArrayTests where + +import Test.Framework.Providers.HUnit +import Test.Framework (Test, defaultMain, testGroup) +-- [2013.09.26] Temporarily disabling template haskell due to GHC bug discussed here: +-- https://github.com/rrnewton/haskell-lockfree/issues/10 +import Test.Framework.TH (testGroupGenerator) +import Test.HUnit (Assertion, assertEqual, assertBool, Counts(..)) +import qualified Test.HUnit as HU +import TestHelpers (defaultMainSeqTests) + +import Control.Applicative +import Control.Monad +import Control.Concurrent +import Control.Concurrent.MVar +import GHC.Conc +import Data.List (isInfixOf, intersperse) +import qualified Data.Vector as V +import qualified Data.Set as S +import Data.IORef +import Data.Time.Clock +import System.Environment (getArgs) +import System.IO +import System.Exit +import System.Random + +import Control.Exception (catch, evaluate, SomeException) + +import Data.Traversable (traverse) +import qualified Data.Set as S +import qualified Data.Map as M +import Data.Word + + -- TODO: Remove most of this! This file should not tests LVars other than IVars: + +import qualified Data.LVar.Generic as G +import qualified Data.LVar.NatArray as NA +import Data.LVar.PureSet as IS +import Data.LVar.PureMap as IM + +import qualified Data.LVar.SLMap as SM +import qualified Data.LVar.SLSet as SS +import Data.LVar.Memo as Memo + +import qualified Data.LVar.IVar as IV +import qualified Data.LVar.IStructure as ISt +import qualified Data.LVar.Pair as IP + +import Control.LVish +import Control.LVish.DeepFrz (DeepFrz(..), Frzn, Trvrsbl, runParThenFreeze, runParThenFreezeIO) +import qualified Control.LVish.Internal as I +import Control.LVish.SchedIdempotent (liftIO, dbgLvl, forkWithExceptions) +import qualified Control.LVish.SchedIdempotent as L + +import qualified Data.Concurrent.SNZI as SNZI +import qualified Data.Concurrent.LinkedMap as LM +import qualified Data.Concurrent.SkipListMap as SLM + +import Debug.Trace +import TestHelpers as T + +-------------------------------------------------------------------------------- + +runTests :: IO () +runTests = defaultMainSeqTests [tests] + +-- SADLY, this use of template-Haskell, together with the atomic-primops dependency, +-- triggers a GHC linking bug: +tests :: Test +tests = $(testGroupGenerator) + +-------------------------------------------------------------------------------- +-- NatArrays +-------------------------------------------------------------------------------- + +case_v9a :: Assertion +case_v9a = assertEqual "basic NatArray" 4 =<< v9a +v9a :: IO Word8 +v9a = runParIO$ do + arr <- NA.newNatArray 10 + NA.put arr 5 (4::Word8) + NA.get arr 5 + + +-- #ifdef NO_DANGLING_THREADS +-- case_i9b :: Assertion +-- case_i9b = exceptionOrTimeOut 0.3 [] i9b +-- -- | A test to make sure that we get an error when we should. +-- i9b :: IO Word8 +-- i9b = runParIO$ do +-- arr:: NA.NatArray s Word8 <- NA.newNatArray 10 +-- fork $ do NA.get arr 5 +-- logDbgLn "Unblocked! Shouldn't see this." +-- return () +-- return 9 +-- #endif + +case_i9c :: Assertion +case_i9c = exceptionOrTimeOut 0.3 ["thread blocked indefinitely"] i9c +i9c :: IO Word8 +i9c = runParIO$ do + arr:: NA.NatArray s Word8 <- NA.newNatArray 10 + fork $ do NA.get arr 5 + logDbgLn 1 "Unblocked! Shouldn't see this." + NA.put arr 6 99 + NA.get arr 6 + +case_v9d :: Assertion +case_v9d = assertEqual "NatArray blocking/unblocking" 99 =<< v9d +v9d :: IO Word8 +v9d = runParIO$ do + arr:: NA.NatArray s Word8 <- NA.newNatArray 10 + fork $ do NA.get arr 5 + logDbgLn 1 "Unblocked! Good." + NA.put arr 6 99 + logDbgLn 1 "After fork." + NA.put arr 5 5 + NA.get arr 6 + +in9e :: Int +in9e = case numElems of + Just x -> x + -- 100000 -- This was where lots of problems happen. + Nothing -> 10000 -- Wait... still plenty of problems at this size. + +out9e :: Word64 +out9e = fromIntegral$ in9e * (in9e + 1) `quot` 2 -- 5000050000 + +-- | Fill in all elements of a NatArray, and then sum them. +v9e :: IO Word64 +v9e = runParIO$ do + let size = in9e + arr <- NA.newNatArray size + fork $ + forM_ [0..size-1] $ \ix -> + NA.put arr ix (fromIntegral ix + 1) -- Can't put 0 + logDbgLn 1 $ "v9e: After fork. Filling array of size "++show size + let loop !acc ix | ix == size = return acc + | otherwise = do v <- NA.get arr ix + loop (acc+v) (ix+1) + loop 0 0 +-- NOTE: this test takes about 0.03 seconds (with input size ?????) +-- It is not faster with two threads, alas... but it is higher variance! + +-- WARNING: I'm seeing some livelocks here that depend on the number of threads +-- (e.g. at -N4 but not -N2). When deadlocked on -N4 it burns 250% cpu. +-- +-- [2013.08.05] Update... it can pass 100 iterations at -N4 BY ITSELF, +-- but fails much more rapidly when run together with other 'v9' +-- tests. +case_v9e_NatArr :: Assertion +case_v9e_NatArr = assertEqual "Scale up a bit" out9e =<< v9e + + +-- Uh oh, this is blocking indefinitely sometimes... +-- BUT, only when I run the whole test suite.. via cabal install --enable-tests +case_i9h :: Assertion +case_i9h = exceptionOrTimeOut 0.3 ["Attempt to put zero"] i9i +i9i :: IO Word +i9i = runParIO$ do + arr <- NA.newNatArray 1 + NA.put arr 0 0 + NA.get arr 0 + +-------------------------------------------------------------------------------- +-- Array of IVar +-------------------------------------------------------------------------------- + +-- | Here's the same test as v9e with an actual array of IVars. +-- This one is reliable, but takes about 0.20-0.30 seconds. +case_v9f1_ivarArr :: Assertion +-- [2013.08.05] RRN: Actually I'm seeing the same non-deterministic +-- thread-blocked-indefinitely problem here. +-- [2013.12.13] It can even happen at NUMELEMS=1000 (with debug messages slowing it) +-- Could this possibly be a GHC bug? +-- [2013.12.13] Runaway duplication of callbacks is ALSO possible on this test. +-- Bafflingly that happens on DEBUG=2 but not 5. +case_v9f1_ivarArr = assertEqual "Array of ivars, compare effficiency:" out9e =<< v9f +v9f :: IO Word64 +v9f = runParIO$ do + let size = in9e + news = V.replicate size IV.new + arr <- V.sequence news + fork (do logDbgLn 1 " [v9f] Beginning putter loop.." + forM_ [0..size-1] $ \ix -> + IV.put_ (arr V.! ix) (fromIntegral ix + 1)) + logDbgLn 1 " [v9f] After fork." + let loop !acc ix | ix == size = return acc + | otherwise = do v <- IV.get (arr V.! ix) + when (ix `mod` 1000 == 0) $ +-- trace (" [v9f] get completed at: "++show ix) $ return () + logDbgLn 2 $ " [v9f] get completed at: "++show ix++" -> "++show v + loop (acc+v) (ix+1) + loop 0 0 + +-- | A variation of the previous. In this version +case_v9f2 :: Assertion +case_v9f2 = assertEqual "Array of ivars, compare effficiency:" out9e =<< runParIO (do + let size = in9e + news = V.replicate size IV.new + arr <- V.sequence news + let putters = do + logDbgLn 1 " [v9f2] Beginning putter loop.." + forM_ [0..size-1] $ \ix -> + IV.put_ (arr V.! ix) (fromIntegral ix + 1) + logDbgLn 1 " [v9f2] After fork." + let loop !acc ix | ix == size = return acc + | otherwise = do v <- IV.get (arr V.! ix) + when (ix `mod` 1000 == 0) $ + logDbgLn 2 $ " [v9f2] get completed at: "++show ix++" -> "++show v + loop (acc+v) (ix+1) + fut <- spawn (loop 0 0) + putters + IV.get fut) + + +-------------------------------------------------------------------------------- +-- IStructure +-------------------------------------------------------------------------------- + +-- | One more time with a full IStructure. +case_v9g_istruct :: Assertion +case_v9g_istruct = assertEqual "IStructure, compare effficiency:" out9e =<< v9g +v9g :: IO Word64 +v9g = runParIO$ do + let size = in9e + arr <- ISt.newIStructure size + fork $ + forM_ [0..size-1] $ \ix -> + ISt.put_ arr ix (fromIntegral ix + 1) + logDbgLn 1 "After fork." + let loop !acc ix | ix == size = return acc + | otherwise = do v <- ISt.get arr ix + loop (acc+v) (ix+1) + loop 0 0 + + +case_show04 :: Assertion +case_show04 = assertEqual "show for IStructure" "{IStructure: Just 33, Just 44}" show04 +show04 :: String +show04 = show$ runParThenFreeze $ do + ist <- ISt.newIStructure 2 + ISt.put ist 0 (33::Int) + ISt.put ist 1 (44::Int) + return ist + diff --git a/tests/GenericTests.hs b/tests/GenericTests.hs new file mode 100644 --- /dev/null +++ b/tests/GenericTests.hs @@ -0,0 +1,79 @@ + +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DataKinds #-} + +-- | Tests for the generic Par-programming interfaces. + +module GenericTests (tests, runTests) where + +import Control.Monad +import Data.Maybe (fromMaybe) +import Data.Word +import qualified Control.Par.Class as PC +import Control.Par.Class.Unsafe (internalLiftIO) +import Test.HUnit (Assertion, assertEqual, assertBool, Counts(..)) +import Test.Framework.TH (testGroupGenerator) +import Test.Framework (defaultMain, Test) +import Test.Framework.Providers.HUnit (testCase) -- For macro-expansion. + +import TestHelpers as T +import Control.LVish -- LVarSched instances... +import Data.LVar.IVar as IV +import qualified Data.LVar.SLMap as SM +import qualified Control.Par.Class as PC +import Data.Par.Range (zrange) +import Data.Par.Splittable (pforEach) + +-------------------------------------------------------------------------------- + + +case_toQPar :: Assertion +case_toQPar = t1 >>= assertEqual "" "hi" + +t1 :: IO String +t1 = runParIO par + where + par :: Par QuasiDet s String + par = do + iv <- IV.new + PC.toQPar $ IV.put iv "hi" + IV.get iv + +-------------------------------------------------------------------------------- + +size :: Int +size = fromMaybe 100 numElems + +expectedSum :: Word64 +expectedSum = (s * (s + 1)) `quot` 2 + where s = fromIntegral size + +-- ParFold instance +case_pfold_imap :: Assertion +case_pfold_imap = assertNoTimeOut 3.0 $ runParIO $ do + mp <- SM.newEmptyMap + -- pforEach (zrange sz) $ \ ix -> do + forM_ [1..size] $ \ ix -> do + SM.insert ix (fromIntegral ix::Word64) mp + + logDbgLn 1 $ "IMap filled up... freezing" + fmp <- SM.freezeMap mp + logDbgLn 3 $ "Frozen: "++show fmp + let mapper (_k,x) = do + logDbgLn 2 $ "Mapping in parallel: "++show x + return x + folder x y = do + logDbgLn 2 $ "Summing in parallel "++show (x,y) + return $! x+y + summed <- PC.pmapFold mapper folder 0 fmp + logDbgLn 1 $ "Sum of IMap values: " ++ show summed + internalLiftIO$ assertEqual "Sum of IMap values" expectedSum summed + return () + +-------------------------------------------------------------------------------- + +tests :: Test +tests = $(testGroupGenerator) + +runTests :: IO () +runTests = defaultMainSeqTests [tests] diff --git a/tests/LVishAndIVar.hs b/tests/LVishAndIVar.hs new file mode 100644 --- /dev/null +++ b/tests/LVishAndIVar.hs @@ -0,0 +1,423 @@ +{-# LANGUAGE TemplateHaskell, CPP, ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE NamedFieldPuns #-} + +-- | Core tests for the LVish scheduler and basic futures/IVars. + +module LVishAndIVar(tests, runTests) where + +import Test.Framework.Providers.HUnit +import Test.Framework (Test, defaultMain, testGroup) +-- [2013.09.26] Temporarily disabling template haskell due to GHC bug discussed here: +-- https://github.com/rrnewton/haskell-lockfree/issues/10 +import Test.Framework.TH (testGroupGenerator) + +import Test.HUnit (Assertion, assertEqual, assertBool) +import qualified Test.HUnit as HU +import Control.Applicative +import Control.Monad +import Control.Concurrent +import Control.Concurrent.MVar +import GHC.Conc +import Data.List (isInfixOf, intersperse) +import qualified Data.Vector as V +import qualified Data.Set as S +import Data.IORef +import Data.Time.Clock +import Debug.Trace +import System.Environment (getArgs) +import System.IO +import System.Exit +import System.Random + +import Control.Exception (catch, evaluate, SomeException) + +import Data.Traversable (traverse) +import qualified Data.Set as S +import qualified Data.Map as M +import Data.Word + +import qualified Data.LVar.IVar as IV + +import Control.LVish +import Control.LVish.DeepFrz (DeepFrz(..), Frzn, Trvrsbl, runParThenFreeze, runParThenFreezeIO) +import qualified Control.LVish.Internal as I +import Control.LVish.SchedIdempotent (liftIO, dbgLvl, forkWithExceptions) +import qualified Control.LVish.SchedIdempotent as L + +import TestHelpers2 as T + +-------------------------------------------------------------------------------- + +runTests :: IO () +runTests = defaultMain [tests] + +-- SADLY, this use of template-Haskell, together with the atomic-primops dependency, +-- triggers a GHC linking bug: +tests :: Test +tests = $(testGroupGenerator) + +-------------------------------------------------------------------------------- + +-- | This stress test does nothing but run runPar again and again. +case_runParStress :: HU.Assertion +case_runParStress = stressTest T.stressTestReps 15 (return ()) (\()->True) + +-- TEMP: another version that uses the simplest possible method to run lots of runPars. +-- Nothing else that could POSSIBLY get in the way. +-- +-- [2014.01.16] Very odd! I'm not able to get the crash here, but I am for the +-- runParsStress test... Actually, I'm having trouble getting the crash with less +-- than 20 threads in the runtime for the old test too. That is, the first of these +-- crashes quickly, and the second one won't crash for me: +-- +-- STRESSTESTS=15000 ./LVishAndIVar.exe -t runParStress +RTS -N20 +-- STRESSTESTS=15000 ./LVishAndIVar.exe -t runParStress +RTS -N15 +-- +-- Oddly, it seems to go from happening rarely at -N17 to often at -N18. +-- I think the problem with the simple test that uses "runParIO" is that we +-- can't make the runtime use more capabilities than we fork par worker threads. +-- This could be a GHC runtime bug relating to thread migration? +case_lotsaRunPar :: Assertion +case_lotsaRunPar = loop iters + where + iters = 5000 + loop 0 = putStrLn "" + loop i = do + -- We need to do runParIO to make sure the compiler does the runPar each time. + -- runParIO (return ()) -- Can't crash this one. + runParDetailed (DbgCfg Nothing [] True) 15 (return ()) + -- This version can start going RIDICULOUSLY slowly with -N20. It will use <20% CPU while it does it. + -- But it won't use much memory either... what is it doing? With -N4 it goes light years faster, and with -N2 + -- faster yet. Extra capabilities result in a crazy slowdown here. + -- With the bad behavior on -N20, it will SOMETIMES complete 5000 iterations in ~3 seconds. But sometimes + -- it will grind to a snails pace after a few hundred iterations. + -- The missing time doesn't show up as system or CPU time... + -- At -N15, where the # workers matches the # capabilities, it keeps up an ok pace... + -- -qa doesn't seem to help the problem. + -- -qm seems to EXACERBATE the problem, making it happen from the start and consistently. + -- (even then, it is fine with -N15, the mismatch is the problem) + -- Playing around with -C, -qb -qg -qi doesn't seem to do anything. + traceEventIO ("Finish iteration "++show (iters-i)) + -- For debugging I put in this traceEvent and ran with +RTS -N18 -qm -la + putStr "."; hFlush stdout + loop (i-1) + + +-- Disabling thread-variation due to below bug: + +-- EEK! Just got this [2013.06.27]: +-- +-- unit-tests.exe: internal error: wakeup_gc_threads +-- (GHC version 7.6.3 for x86_64_unknown_linux) +-- Please report this as a GHC bug: http://www.haskell.org/ghc/reportabug +-- Aborted (core dumped) + +case_v0 :: HU.Assertion +case_v0 = do res <- v0 + HU.assertEqual "useless fork" (4::Int) res +v0 = runParIO $ do i <- IV.new; fork (return ()); IV.put i 4; IV.get i + + +case_v1a :: Assertion +case_v1a = assertEqual "fork put" (4::Int) =<< v1a +v1a :: IO Int +v1a = runParIO $ do i<-IV.new; fork (IV.put i 4); IV.get i + +case_v1b :: Assertion +case_v1b = do ls <- v1b + case length ls of + 0 -> return () -- Ok, i guess debugging is off. + 1 -> return () + _ -> error $ "Wrong number of log messages: \n" ++ concat (intersperse "\n" ls) + +-- | In this sequential case there should be no data-race, and thus no duplication of the callback. +v1b :: IO [String] +v1b = do let tag = "callback on ivar " + (logs,_) <- runParLogged $ do + i <- IV.new + IV.put i (3::Int) + IV.whenFull Nothing i (\x -> logDbgLn 1$ tag++show x) + IV.put i 3 + IV.put i 3 + return () + mapM_ putStrLn logs + return (filter (isInfixOf tag) logs) + +escape01 :: IV.IVar Frzn Int +escape01 = runParThenFreeze $ do v <- IV.new; IV.put v (3::Int); return v + +-- | This is VERY BAD: +escape01B :: Par d Frzn String +escape01B = + do IV.put escape01 (4::Int) + return "uh oh" + +-- | [2013.10.06] Fixed this by requiring a SPECIFIC type, NonFrzn. +-- major_bug :: String +-- major_bug = runParThenFreeze escape01B + +-- | Simple callback test. +-- case_v3a :: Assertion +-- case_v3a = v3a >>= assertEqual "simple callback test" +-- (S.fromList [10,20,30,40,50,60,70,80,90,100] :: S.Set Int) + + +-- RRN: Currently we have a policy where leaving the seen with running threads is +-- disallowed, but blocked ones are tolerated. +case_i3f :: Assertion +case_i3f = exceptionOrTimeOut 0.3 ["test switched off"] i3f +i3f :: IO () +#ifdef NO_DANGLING_THREADS +-- | A test to make sure that we get an error when we block on an unavailable ivar. +i3f = runParIO$ do + iv <- IV.new + fork $ do IV.get iv + logDbgLn 1 "Unblocked! Shouldn't see this." + return () + return () +#else +i3f = error "test switched off" +#endif + +case_i3g :: Assertion +case_i3g = exceptionOrTimeOut 0.3 [] i3g +-- | A still-running worker thread should NOT be allowed, because it may do a put that causes an exception. +i3g :: IO Word8 +i3g = runParIO$ do + iv <- IV.new + fork $ do let loop !ls = loop [1 .. length ls] + loop [1..10] + return 9 + +-------------------------------------------------------------------------------- +-- Higher level derived ops +-------------------------------------------------------------------------------- + + + +-------------------------------------------------------------------------------- +-- Looping constructs +-------------------------------------------------------------------------------- + +case_lp01 :: Assertion +case_lp01 = assertEqual "parForSimple test" "done" =<< lp01 +lp01 = runParIO$ do + logDbgLn 2 " [lp01] Starting parForSimple loop..." + x <- IV.new + parForSimple (0,10) $ \ ix -> do + logDbgLn 2$ " [lp01] iter "++show ix + when (ix == 9)$ IV.put x "done" + IV.get x + +case_lp02 :: Assertion +case_lp02 = assertEqual "parForL test" "done" =<< lp02 +lp02 = runParIO$ do + logDbgLn 2 " [lp02] Starting parForL loop..." + x <- IV.new + parForL (0,10) $ \ ix -> do + logDbgLn 2$ " [lp02] iter "++show ix + when (ix == 9)$ IV.put x "done" + logDbgLn 2$ " [lp02] after loop..." + IV.get x + +-- [2013.08.05] RRN: I'm seeing this hang sometimes. It live-locks +-- burning CPU. (But only 170% CPU with -N4.) Hmm, I can't get it to +-- freeze running BY ITSELF, however. In fact I can't get the problem +-- while running just the "lp" tests. I can get the problem running +-- just 'v' tests and even just 'v9' tests. +case_lp03 :: Assertion +case_lp03 = assertEqual "parForTree test" "done" =<< lp03 +lp03 = runParIO$ do + logDbgLn 2 " [lp03] Starting parForTree loop..." + x <- IV.new + parForTree (0,10) $ \ ix -> do + logDbgLn 2$ " [lp03] iter "++show ix + when (ix == 9)$ IV.put x "done" + logDbgLn 2$ " [lp03] after loop..." + IV.get x + +case_lp04 :: Assertion +case_lp04 = assertEqual "parForTree test" "done" =<< lp04 +lp04 = runParIO$ do + logDbgLn 2 " [lp04] Starting parForTiled loop..." + x <- IV.new + parForTiled Nothing 16 (0,10) $ \ ix -> do + logDbgLn 2$ " [lp04] iter "++show ix + when (ix == 9)$ IV.put x "done" + logDbgLn 2$ " [lp04] after loop..." + IV.get x + +-------------------------------------------------------------------------------- +-- TEMPLATE HASKELL BUG? -- if we have *block* commented case_foo decls, it detects +-- those when it shouldn't: +-------------------------------------------------------------------------------- + +-- -- | Simple test of pairs. +-- case_v4 :: Assertion +-- case_v4 = v4 >>= assertEqual "simple-pair" (3, "hi") + +-- v4 :: IO (Int,String) +-- v4 = runParIO $ +-- do p <- newPair +-- putFst p 3 +-- putSnd p "hi" +-- x <- getFst p +-- y <- getSnd p +-- return (x,y) + +-- -- | This program should throw an exception due to multiple puts. +-- case_i5a :: Assertion +-- case_i5a = assertException ["Multiple puts to an IVar!"] i5a + +-- i5a :: IO Int +-- i5a = runParIO ( +-- do p <- newPair +-- putFst p 3 +-- putSnd p "hi" +-- putSnd p "there" +-- getFst p) + +-- -- | Another exception due to multiple puts. This tests whether the scheduler waits +-- -- around for a trailing (errorful) computation that is not on the main thread. +-- case_i5b :: Assertion +-- case_i5b = assertException ["Multiple puts to an IVar!"] i5b + +-- i5b = +-- runParIO $ +-- do p <- newPair +-- putFst p 3 +-- putSnd p "hi" +-- fork $ do waste_time +-- putSnd p "there" +-- -- There's no 'consume' here; so we should really just get a +-- -- "Multiple puts to an IVar!" exception. +-- getSnd p + +-- -- | Similar to 5b but with the branches flipped. +-- case_i5c :: Assertion +-- case_i5c = assertException ["Multiple puts to an IVar!"] i5c + +-- i5c = runParIO $ +-- do p <- newPair +-- putSnd p "hi" + +-- -- The forked thread's value is not returned, so we go to a little extra work +-- -- here to bounce the value through the First of the pair. +-- fork $ putFst p =<< getSnd p +-- waste_time + +-- putSnd p "there" +-- getFst p + +-- -- | Another multiple put error. This one makes sure that ANY tops get thrown as +-- -- exceptions, or we have full nondeterminism (not even limited guarantees), the +-- -- program would return "a" or "b". +-- case_i6a :: Assertion +-- case_i6a = assertException ["Multiple puts to an IVar!"] i6a +-- i6a = runParIO ( +-- do p <- newPair +-- putFst p 3 + +-- -- TODO: Randomize these amounts of time: +-- fork $ do waste_time +-- putSnd p "a" +-- fork $ do waste_time +-- putSnd p "b" +-- -- There's no 'consume' here; so we should really just get a +-- -- "Multiple puts to an IVar!" exception. +-- getSnd p) + + +-- -- TODO: +-- -------------------------------- +-- -- | This test, semantically, has two possible outcomes. It can return "hi" or an +-- -- error. That's quasi-determinism. In practice, we force it to have one outcome by +-- -- wasting a significant amount of time in one branch. +-- -------------------------------- + + +-- waste_time = loop 1000 3.3 +-- where +-- loop 0 acc = if acc < 10 then return acc else return 0 +-- loop i !acc = loop (i - 1) (sin acc + 1.0) + +-- -- More pairs +-- case_v6 :: Assertion +-- case_v6 = assertEqual "fancy pairs" +-- 33 =<< runParIO ( +-- do p1 <- newPair +-- p2 <- newPair +-- fork $ do x <- getFst p1 +-- putSnd p2 x +-- fork $ do x <- getSnd p2 +-- putSnd p1 x +-- putFst p1 33 +-- getSnd p1) + + +-------------------------------------------------------------------------------- +-- Freeze-related tests: +-------------------------------------------------------------------------------- + +case_dftest0 = assertEqual "manual freeze, outer layer" "hello" =<< dftest0 + +dftest0 :: IO String +dftest0 = runParIO $ do + iv1 <- IV.new + iv2 <- IV.new + IV.put_ iv1 iv2 + IV.put_ iv2 "hello" + m <- IV.freezeIVar iv1 + case m of + Just i -> IV.get i + +case_dftest1 = assertEqual "deefreeze double ivar" (Just "hello") =<< dftest1 + +-- | Should return (Just (Just "hello")) +dftest1 :: IO (Maybe String) +dftest1 = runParIO $ do + iv1 <- IV.new + iv2 <- IV.new + IV.put_ iv1 iv2 + IV.put_ iv2 "hello" + Just x <- IV.freezeIVar iv1 + IV.freezeIVar x + +case_dftest3 = assertEqual "freeze simple ivar" (Just 3) =<< dftest3 +dftest3 :: IO (Maybe Int) +dftest3 = runParIO $ do + iv1 <- IV.new + IV.put_ iv1 (3::Int) + IV.freezeIVar iv1 + + +--FIXME: + +-- -- | Polymorphic version of previous. DeepFrz is more flexible than regular +-- -- freeze, because we can pick multiple return types for the same code. But we must +-- -- be very careful with this kind of thing due to the 's' type variables. +-- dftest4_ :: DeepFrz (IV.IVar s1 Int) => +-- Par QuasiDet s1 b +-- dftest4_ = do +-- iv1 <- newBottom +-- IV.put_ iv1 (3::Int) +-- res <- IV.freezeIVar iv1 +-- return res + +-- case_dftest4a = assertEqual "freeze polymorphic 1" (Just 3) =<< dftest4a +-- dftest4a :: IO (Maybe Int) +-- dftest4a = runParIO dftest4_ + +------------------------------------------------------------------------------------------ +-- Show instances +------------------------------------------------------------------------------------------ + +case_show01 :: Assertion +case_show01 = assertEqual "show for IVar" "Just 3" show01 +show01 :: String +show01 = show$ runParThenFreeze $ do v <- IV.new; IV.put v (3::Int); return v + diff --git a/tests/LogicalTests.hs b/tests/LogicalTests.hs new file mode 100644 --- /dev/null +++ b/tests/LogicalTests.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE TemplateHaskell #-} + +module LogicalTests where + +import Control.LVish +import Data.LVar.IVar as IV + +import Test.HUnit (Assertion, assert, assertEqual, assertBool, Counts(..)) +-- import Test.QuickCheck () +import Test.Framework.Providers.HUnit +-- import Test.Framework.Providers.QuickCheck2 +import Test.Framework -- (Test, defaultMain, testGroup) +import Test.Framework.TH (testGroupGenerator) +import TestHelpers (defaultMainSeqTests) + +-------------------------------------------------------------------------------- +-- TESTS: +-------------------------------------------------------------------------------- + +case_and1 :: Assertion +case_and1 = assertEqual "" False $ runPar $ do + v <- IV.new + asyncAnd Nothing (return True) (return False) (IV.put v) + IV.get v + +case_and2 :: Assertion +case_and2 = assertEqual "" False $ runPar $ do + v <- IV.new + asyncAnd Nothing (return False) (return False) (IV.put v) + IV.get v + +case_and3 :: Assertion +case_and3 = assertEqual "" True $ runPar $ do + v <- IV.new + asyncAnd Nothing (return True) (return True) (IV.put v) + IV.get v + +case_and4 :: Assertion +case_and4 = assertEqual "" False $ runPar $ do + v <- IV.new + asyncAnd Nothing (return False) (return True) (IV.put v) + IV.get v + +case_or1 :: Assertion +case_or1 = assertEqual "" True $ runPar $ do + v <- IV.new + asyncOr Nothing (return True) (return False) (IV.put v) + IV.get v + +case_or2 :: Assertion +case_or2 = assertEqual "" False $ runPar $ do + v <- IV.new + asyncOr Nothing (return False) (return False) (IV.put v) + IV.get v + +case_or3 :: Assertion +case_or3 = assertEqual "" True $ runPar $ do + v <- IV.new + asyncOr Nothing (return True) (return True) (IV.put v) + IV.get v + +case_or4 :: Assertion +case_or4 = assertEqual "" True $ runPar $ do + v <- IV.new + asyncOr Nothing (return False) (return True) (IV.put v) + IV.get v + +case_andMap01 :: Assertion +case_andMap01 = assertEqual "" False $ runPar $ + andMap Nothing (return . even) [1..200::Int] + +case_orMap01 :: Assertion +case_orMap01 = assertEqual "" True $ runPar $ + orMap Nothing (return . even) [1..200::Int] + +-- TODO: add ones with explicit timing controls (sleep). + +-------------------------------------------------------------------------------- + +tests :: Test +tests = $(testGroupGenerator) + +runTests :: IO () +runTests = defaultMainSeqTests [tests] diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,49 @@ +-- #!/usr/bin/env runghc -i.. + +{-# LANGUAGE CPP #-} + +-- | This module aggregates all the unit tests in this directory. + +module Main where + +import Test.Framework (Test) +import TestHelpers (defaultMainSeqTests) + +import qualified MemoTests +import qualified LVishAndIVar +import qualified ArrayTests +import qualified LogicalTests +import qualified SkipListTests +--import qualified SNZITests +import qualified PureMapTests +import qualified SLMapTests +import qualified SetTests +import qualified MaxCounterTests +import qualified AddRemoveSetTests + +#ifdef GENERIC_PAR +import qualified GenericTests +#endif + +main :: IO () +main = defaultMainSeqTests alltests + +alltests :: [Test] +alltests = + [ LVishAndIVar.tests + , ArrayTests.tests + , MemoTests.tests + , LogicalTests.tests + , MaxCounterTests.tests + , SetTests.tests + , PureMapTests.tests +#ifdef FAILING_TESTS + , SLMapTests.tests -- TODO: close Issue #27, #28 first. + , SkipListTests.tests -- Seems to diverge on some sizes on slm2/slm3 [2013.12.07] +-- , SNZITests.tests -- These have failures still [2013.10.23] +#ifdef GENERIC_PAR + , GenericTests.tests -- Divergence... debugging [2013.12.07] +#endif +#endif + , AddRemoveSetTests.tests + ] diff --git a/tests/MaxCounterTests.hs b/tests/MaxCounterTests.hs new file mode 100644 --- /dev/null +++ b/tests/MaxCounterTests.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DataKinds #-} + +-- | Tests for the Data.LVar.MaxCounter module. + +module MaxCounterTests(tests, runTests) where + +import Test.Framework.Providers.HUnit +import Test.Framework (Test, defaultMain, testGroup) +import Test.HUnit (Assertion, assertEqual, assertBool, Counts(..)) +import Test.Framework.TH (testGroupGenerator) +import qualified Test.HUnit as HU +import TestHelpers as T + +import Control.Concurrent (killThread, myThreadId) + +import Data.LVar.MaxCounter +import Control.LVish hiding (put) +import Control.LVish.DeepFrz (DeepFrz(..), Frzn, Trvrsbl, runParThenFreeze, runParThenFreezeIO) +import qualified Control.LVish.Internal as I + +-------------------------------------------------------------------------------- + +tests :: Test +tests = $(testGroupGenerator) + +runTests :: IO () +runTests = defaultMainSeqTests [tests] + +-------------------------------------------------------------------------------- + +case_mc1 :: Assertion +-- Spuriously failing currently: +-- case_mc1 = assertEqual "mc1" (Just ()) $ timeOutPure 0.3 $ runPar $ do +case_mc1 = assertEqual "mc1" () $ runPar $ do + num <- newMaxCounter 0 + fork $ put num 3 + fork $ put num 4 + waitThresh num 4 + +case_mc2 :: Assertion +case_mc2 = assertEqual "mc2" () $ runPar $ do + num <- newMaxCounter 0 + fork $ put num 3 + fork $ put num 4 diff --git a/tests/MemoTests.hs b/tests/MemoTests.hs new file mode 100644 --- /dev/null +++ b/tests/MemoTests.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE TemplateHaskell, ParallelListComp #-} + +-- | Test only the memoization functionality, corresponds to the @Data.LVar.Memo*@ +-- modules. + +module MemoTests where +import Control.LVish + +import Data.LVar.CycGraph + +import qualified Data.LVar.IVar as IV +import Data.Set as S +import Test.HUnit (Assertion, assertEqual, assertBool, Counts(..)) +import Test.Framework.TH (testGroupGenerator) +import Test.Framework (defaultMain, Test) +import Test.Framework.Providers.HUnit (testCase) -- For macro-expansion. +import TestHelpers (defaultMainSeqTests) + +import Prelude as P + +-------------------------------------------------------------------------------- +-- Unit Tests +-------------------------------------------------------------------------------- + +-- This has changed a bunch, update it: [2013.10.23] +{- +cyc02 :: IO String +cyc02 = runParIO $ exploreGraph + (\33 -> return [33]) + (\cyc k nbrs -> + return ("key "++show k++" cyc "++show cyc++" nbrs "++show (P.map fst nbrs))) + (33::Int) + +cyc03 :: IO String +cyc03 = runParIO $ exploreGraph fn1 fn2 33 + where + fn1 33 = return [44] + fn1 44 = return [33] + fn2 cyc k nbrs = return ("key "++show k++" cyc "++show cyc++" nbrs "++show (P.map fst nbrs)) + +cyc04 :: IO String +cyc04 = runParIO $ exploreGraph fn1 hndlr 33 + where + fn1 33 = return [44] + fn1 44 = return [55] + fn1 55 = return [33] + + hndlr True 55 nbrs = return "stop-at-55" + hndlr cyc k nbrs = do + vals <- mapM (IV.get . snd) nbrs + return ("key="++show k++" cyc:"++show cyc++" nbrs:("++ + concat [ show k++","++str++" " | (k,_) <- nbrs | str <- vals ] ++")") +-} + +----------------------------------------------- +-- Test the sequential cycle-detection approach +----------------------------------------------- + +case_02seq :: Assertion +case_02seq = assertEqual "direct, one-node cycle, DFS" "cycle-33" cyc02seq +cyc02seq :: String +cyc02seq = runPar $ exploreGraph_seq + (\33 -> return$ Request 33 (\a -> return$ Done$ "33 finished: "++a)) + (\k -> return$ "cycle-"++show k) + 33 + +case_03seq :: Assertion +case_03seq = assertEqual "2-way cycle, DFS" "44 finished: cycle-33" cyc03seq +cyc03seq :: String +cyc03seq = runPar $ exploreGraph_seq fn (\k -> return ("cycle-"++show k)) 44 + where + fn 33 = return (Request 44 (\a -> return (Done$ "33 finished: "++a))) + fn 44 = return (Request 33 (\a -> return (Done$ "44 finished: "++a))) + +case_04seq :: Assertion +case_04seq = assertEqual "3-way cycle, DFS" + "33 complete: 44 complete: cycle-55" cyc04seq + +cyc04seq :: String +cyc04seq = runPar $ exploreGraph_seq fn (\k -> return ("cycle-"++show k)) 33 + where + fn 33 = return (Request 44 (\a -> return (Done$ "33 complete: "++a))) + fn 44 = return (Request 55 (\a -> return (Done$ "44 complete: "++a))) + fn 55 = return (Request 33 (\a -> return (Done$ "55 complete: "++a))) + +cyc05seq :: String +cyc05seq = runPar $ exploreGraph_seq fn (\k -> return ("cycle-"++show k)) 33 + where + fn 33 = return (Request 44 (\a -> return (Done$ "33 complete: "++a))) + fn 44 = return (Request 55 (\a -> return (Done$ "44 complete: "++a))) + fn 55 = return (Request 33 (\a -> return (Done$ "55 complete: "++a))) + + +-------------------------------------------------------------------------------- + +tests :: Test +tests = $(testGroupGenerator) + +runTests :: IO () +runTests = defaultMainSeqTests [tests] diff --git a/tests/PureMapTests.hs b/tests/PureMapTests.hs new file mode 100644 --- /dev/null +++ b/tests/PureMapTests.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DataKinds, TypeFamilies #-} +{-# LANGUAGE CPP #-} + +-- | Tests for the Data.LVar.PureMap and Data.LVar.SLMap modules. + +module PureMapTests(tests, runTests) where + +import Data.LVar.PureSet as IS +import Data.LVar.PureMap as IM + +#include "CommonMapTests.hs" + +-------------------------------------------------------------------------------- + +tests :: Test +tests = testGroup "" [tests_here, tests_common ] + +tests_here :: Test +tests_here = $(testGroupGenerator) + +runTests :: IO () +runTests = defaultMainSeqTests [tests] + +-------------------------------------------------------------------------------- + +-- [2013.08.05] RRN: Observing nondeterministic blocked-indefinitely +-- exception here. +case_i7b :: Assertion +case_i7b = do + allowSomeExceptions ["Multiple puts"] $ + assertEqual "racing insert and modify" + (M.fromList [(1,S.fromList [3.33]), + (2,S.fromList [0.11,4.44])]) =<< + i7b + return () + +-- | A quasi-deterministic example. +i7b :: IO (M.Map Int (S.Set Float)) +-- A manual nested freeze instead of DeepFrz: +i7b = runParIO $ do + mp <- IM.newEmptyMap + s1 <- IS.newEmptySet + s2 <- IS.newEmptySet + IS.insert 0.11 s2 + f1 <- IV.spawn_ $ do IM.insert 1 s1 mp + IM.insert 2 s2 mp + f2 <- IV.spawn_ $ do s <- IM.getKey 1 mp + IS.insert 3.33 s + -- RACE: this modify is racing with the insert of s2: + IM.modify mp 2 IS.newEmptySet (IS.insert 4.44) + + IV.get f1; IV.get f2 + mp2 <- IM.freezeMap mp + traverse IS.freezeSet mp2 + +-- | This example is valid because two modifies may race. +v7c :: IO (M.Map Int (S.Set Float)) +-- Do we need a "deep freeze" that freezes nested structures? +v7c = runParIO $ do + mp <- IM.newEmptyMap + s1 <- IS.newEmptySet + f1 <- IV.spawn_ $ IM.insert 1 s1 mp + f2 <- IV.spawn_ $ do s <- IM.getKey 1 mp + IS.insert 3.33 s + IM.modify mp 2 IS.newEmptySet (IS.insert 4.44) + f3 <- IV.spawn_ $ IM.modify mp 3 IS.newEmptySet (IS.insert 5.55) + f4 <- IV.spawn_ $ IM.modify mp 3 IS.newEmptySet (IS.insert 6.6) + -- No easy way to wait on the total size of all contained sets... + -- + -- Need a barrier here.. should have a monad-transformer that provides cilk "sync" + -- Global quiesce is convenient too.. + IV.get f1; IV.get f2; IV.get f3; IV.get f4 + mp2 <- IM.freezeMap mp + traverse IS.freezeSet mp2 + +case_v7c :: Assertion +case_v7c = assertEqual "imap test - racing modifies" + (M.fromList [(1,S.fromList [3.33]), + (2,S.fromList [4.44]), + (3,S.fromList [5.55,6.6])]) =<< + v7c + +------------------------------------------------------------------------------------------ +-- Show instances +------------------------------------------------------------------------------------------ + +case_show03 :: Assertion +case_show03 = assertEqual "show for PureMap" "{IMap: (\"key1\",33), (\"key2\",44)}" show03 +show03 :: String +show03 = show$ runParThenFreeze $ do + mp <- IM.newEmptyMap + IM.insert "key1" (33::Int) mp + IM.insert "key2" (44::Int) mp + return mp + + diff --git a/tests/SLMapTests.hs b/tests/SLMapTests.hs new file mode 100644 --- /dev/null +++ b/tests/SLMapTests.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DataKinds, TypeFamilies #-} +{-# LANGUAGE CPP #-} + +-- | Tests for the Data.LVar.PureMap and Data.LVar.SLMap modules. + +module SLMapTests(tests, runTests) where + +import qualified Data.LVar.SLSet as IS +import qualified Data.LVar.SLMap as IM +import qualified Data.Concurrent.SkipListMap as SLM + +import qualified Data.LVar.SLMap as SM + +#include "CommonMapTests.hs" + +-------------------------------------------------------------------------------- + +tests :: Test +tests = testGroup "" [tests_here, tests_common ] + +tests_here :: Test +tests_here = $(testGroupGenerator) + +runTests :: IO () +runTests = defaultMainSeqTests [tests] + +------------------------------------------------------------------------------------------ +-- Show instances +------------------------------------------------------------------------------------------ + +-- | It happens that these come out in the opposite order from the Pure one: +case_show02 :: Assertion +case_show02 = assertEqual "show for SLMap" "{IMap: (\"key2\",44), (\"key1\",33)}" show02 +show02 :: String +show02 = show$ runParThenFreeze $ do + mp <- IM.newEmptyMap + SM.insert "key1" (33::Int) mp + SM.insert "key2" (44::Int) mp + return mp + +-------------------------------------------------------------------------------- +-- Issue related: +-------------------------------------------------------------------------------- + +-- -- Issue #27, spurious duplication. +-- case_handlrDup :: Assertion +-- case_handlrDup = runParIO $ do +-- ctr <- I.liftIO$ newIORef 0 +-- mp <- SM.newEmptyMap +-- hp <- newPool +-- -- Register handler FIRST.. no race. +-- SM.forEachHP (Just hp) mp $ \ (k::Int) v -> do +-- logDbgLn 1 $ "[case_handlrDup] Callback executing: " ++ show (k,v) +-- I.liftIO $ incr ctr +-- SM.insert 2 2 mp +-- SM.insert 3 3 mp +-- quiesce hp +-- sum <- I.liftIO $ readIORef ctr +-- I.liftIO $ assertEqual "Should be no duplication in this case" 2 sum + +-- incr :: IORef Int -> IO () +-- incr ref = atomicModifyIORef' ref (\x -> (x+1,())) diff --git a/tests/SetTests.hs b/tests/SetTests.hs new file mode 100644 --- /dev/null +++ b/tests/SetTests.hs @@ -0,0 +1,287 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DataKinds #-} + +-- | Tests for the Data.LVar.PureSet and Data.LVar.SLSet modules. + +module SetTests(tests, runTests) where + +import Test.Framework.Providers.HUnit +import Test.Framework (Test, defaultMain, testGroup) +import Test.HUnit (Assertion, assertEqual, assertBool, Counts(..)) +import Test.Framework.TH (testGroupGenerator) +import qualified Test.HUnit as HU +import TestHelpers as T + +import qualified Data.Set as S + +import qualified Data.LVar.Generic as G +import Data.LVar.PureSet as IS +import qualified Data.LVar.SLSet as SS +import qualified Data.LVar.IVar as IV + +import Control.LVish +import Control.LVish.DeepFrz (DeepFrz(..), Frzn, Trvrsbl, runParThenFreeze, runParThenFreezeIO) + +-------------------------------------------------------------------------------- + +tests :: Test +tests = $(testGroupGenerator) + +runTests :: IO () +runTests = defaultMainSeqTests [tests] + +-------------------------------------------------------------------------------- + +case_v2a :: Assertion +case_v2a = v2a >>= assertEqual "put 10 in & wait" + (S.fromList [1..10] :: S.Set Int) + +-- [2013.06.27] getting thread-blocked-indefinitely errors: +v2a :: IO (S.Set Int) +v2a = runParIO $ + do s <- IS.newEmptySet + mapM_ (\n -> fork $ IS.insert n s) [1..10] + IS.waitSize 10 s + IS.freezeSet s + +-- | This version uses a fork-join so it doesn't need the waitSize: +case_v2b :: Assertion +case_v2b = v2b >>= assertEqual "t2 with spawn instead of fork" + (S.fromList [1..10] :: S.Set Int) + +v2b :: IO (S.Set Int) +v2b = runParIO $ + do s <- IS.newEmptySet + ivs <- mapM (\n -> IV.spawn_ $ IS.insert n s) [1..10] + mapM_ IV.get ivs -- Join point. + IS.freezeSet s + +-- | This version uses deep freeze. +case_v2c :: Assertion +case_v2c = assertEqual "t2 with spawn instead of fork" + (S.fromList [1..10] :: S.Set Int) + (IS.fromISet v2c) + +-- v2c :: S.Set Int +v2c :: IS.ISet Frzn Int +v2c = -- IS.fromISet $ + runParThenFreeze par + where + par :: Par Det s (IS.ISet s Int) + par = + do s <- IS.newEmptySet + ivs <- mapM (\n -> IV.spawn_ $ IS.insert n s) [1..10::Int] + mapM_ IV.get ivs -- Join point. + return s + +-- [2013.06.27] This is failing just occasionally with a multiple-put: +v3a :: IO (S.Set Int) +v3a = runParIO $ + do s1 <- IS.newEmptySet + s2 <- IS.newEmptySet + let fn e = IS.insert (e*10) s2 + IS.withCallbacksThenFreeze s1 fn $ do + -- Populate the first set: + mapM_ (\n -> fork $ IS.insert n s1) [1..10] + -- We never read out of s1 directly. Instead, writes to s1 trigger the + -- callback 'fn' to run, with the element written to s2. So eventually, + -- ten elements are written to s2. + IS.waitSize 10 s2 + IS.freezeSet s2 + +case_v3b :: Assertion +case_v3b = v3b >>= assertEqual "simple callback test" + (S.fromList [10,20,30,40,50,60,70,80,90,100] :: S.Set Int) + +v3b :: IO (S.Set Int) +v3b = runParIO $ + do s1 <- IS.newEmptySet + s2 <- IS.newEmptySet + let fn e = IS.insert (e*10) s2 + IS.withCallbacksThenFreeze s1 fn $ do + -- Populate the first set: + mapM_ (\n -> IS.insert n s1) [1..10] + -- Because we filled s1 sequentially, we know it is full at this point. + -- (If the above were forked we would need a finish/asnyc style construct) + + -- After all of s1's callbacks are finished executing, s2 is full: + IS.freezeSet s2 + + +-- | An under-synchronized test. This should always return the same +-- result OR throw an exception. In this case it should always return +-- a list of 10 elements, or throw an exception. +case_i3c :: Assertion +case_i3c = do + allowSomeExceptions ["Attempt to change a frozen LVar"] $ + do x <- i3c + assertEqual "under-synchronized passed through" + (S.fromList [10,20..100] :: S.Set Int) x + return () + +i3c :: IO (S.Set Int) +i3c = runParIO $ + do s1 <- IS.newEmptySet + s2 <- IS.newEmptySet + let fn e = IS.insert (e*10) s2 + IS.withCallbacksThenFreeze s1 fn $ do + mapM_ (\n -> fork $ IS.insert n s1) [1..10] + IS.waitSize 1 s2 -- Not ENOUGH synchronization! + IS.freezeSet s2 + -- If this ^ freeze occurs *before* all the puts have happened, + -- the a put happening after it will throw an exception. If, + -- on the other hand, it occurs after they've all happened, + -- then we won't notice that anything is wrong and we'll get + -- the same result we would have in case_v3. + +-- FIXME: currently if run enough times, i3c can get the following failure: +-- I think we need to use full Async's so the cancellation goes both ways: + + -- Main: + -- Exception inside child thread "worker thread", ThreadId 12: Attempt to change a frozen LVar + -- Exception inside child thread "worker thread", ThreadId 9: Attempt to change a frozen LVar + -- Exception inside child thread "worker thread", ThreadId 11: Attempt to change a frozen LVar + -- test-lvish: Attempt to change a frozen LVar + -- Exception inside child thread "worker thread", ThreadId 10: thread blocked indefinitely in an MVar operation + + +case_v3d :: Assertion +case_v3d = assertEqual "test of parallelism in freezeSetAfter" + (S.fromList [1..5]) =<< v3d + +-- | This test has interdependencies between callbacks (that are launched on +-- already-present data), which forces these to be handled in parallel. +v3d :: IO (S.Set Int) +v3d = runParIO $ + do s1 <- IS.newFromList [1..5] + s2 <- IS.newEmptySet + IS.freezeSetAfter s1 $ \ elm -> do + let dep = case elm of + 1 -> Just 2 + 2 -> Just 3 + 3 -> Nothing -- Foil either left-to-right or right-to-left + 4 -> Just 3 + 5 -> Just 4 + case dep of + Nothing -> logDbgLn 1 $ " [Invocation "++show elm++"] has no dependencies, running... " + Just d -> do logDbgLn 1 $ " [Invocation "++show elm++"] waiting on "++show dep + IS.waitElem d s2 + logDbgLn 1 $ " [Invocation "++show elm++"] dependency satisfied! " + IS.insert elm s2 + logDbgLn 1 " [freezeSetAfter completed] " + freezeSet s2 + +case_v3e :: Assertion +case_v3e = assertEqual "test of parallelism in forEachHP" + (S.fromList [1..5]) =<< v3e + +-- | Same as v3d but for forEachHP +v3e :: IO (S.Set Int) +v3e = runParIO $ IS.freezeSet =<< + do s1 <- IS.newFromList [1..5] + s2 <- IS.newEmptySet + hp <- newPool + IS.forEachHP (Just hp) s1 $ \ elm -> do + let dep = case elm of + 1 -> Just 2 + 2 -> Just 3 + 3 -> Nothing -- Foil either left-to-right or right-to-left + 4 -> Just 3 + 5 -> Just 4 + case dep of + Nothing -> logDbgLn 1 $ " [Invocation "++show elm++"] has no dependencies, running... " + Just d -> do logDbgLn 1 $ " [Invocation "++show elm++"] waiting on "++show dep + IS.waitElem d s2 + logDbgLn 1 $ " [Invocation "++show elm++"] dependency satisfied! " + IS.insert elm s2 + quiesce hp + logDbgLn 1 " [quiesce completed] " + return s2 + +-------------------------------------------------------------------------------- +-- Higher level derived ops +-------------------------------------------------------------------------------- + +case_v8a :: Assertion +case_v8a = assertEqual "simple cartesian product test" + (S.fromList + [(1,'a'),(1,'b'),(1,'c'), + (2,'a'),(2,'b'),(2,'c'), + (3,'a'),(3,'b'),(3,'c')]) + =<< v8a + +-- v8a :: IO (S.Set (Integer, Char)) +v8a :: IO (S.Set (Integer, Char)) +v8a = runParIO $ do + s1 <- IS.newFromList [1,2,3] + s2 <- IS.newFromList ['a','b'] + logDbgLn 1 " [v8a] now to construct cartesian product..." + h <- newPool + s3 <- IS.cartesianProdHP (Just h) s1 s2 + logDbgLn 1 " [v8a] cartesianProd call finished... next quiesce" + IS.forEach s3 $ \ elm -> + logDbgLn 1$ " [v8a] Got element: "++show elm + IS.insert 'c' s2 + quiesce h + logDbgLn 1 " [v8a] quiesce finished, next freeze::" + freezeSet s3 + +case_v8b :: Assertion +case_v8b = assertEqual "3-way cartesian product" + (S.fromList + [[1,40,101],[1,40,102], [1,50,101],[1,50,102], + [2,40,101],[2,40,102], [2,50,101],[2,50,102]] + ) + =<< v8b + +v8b :: IO (S.Set [Int]) +v8b = runParIO $ do + hp <- newPool + s1 <- IS.newFromList [1,2] + s2 <- IS.newFromList [40,50] + -- (hp,s3) <- IS.traverseSetHP Nothing (return . (+100)) s1 + s3 <- IS.traverseSetHP (Just hp) (return . (+100)) s1 + s4 <- IS.cartesianProdsHP (Just hp) [s1,s2,s3] + IS.forEachHP (Just hp) s4 $ \ elm -> + logDbgLn 1 $ " [v8b] Got element: "++show elm + -- [2013.07.03] Confirmed: this makes the bug(s) go away: + -- liftIO$ threadDelay$ 100*1000 + quiesce hp + logDbgLn 1 " [v8b] quiesce finished, next freeze::" + freezeSet s4 + +------------------------------------------------------------------------------------------ +-- Show instances +------------------------------------------------------------------------------------------ + +case_show05 :: Assertion +case_show05 = assertEqual "show for PureSet" "{ISet: 33, 44}" (show show05) +show05 :: ISet Frzn Int +show05 = runParThenFreeze $ do + is <- IS.newEmptySet + IS.insert (33::Int) is + IS.insert (44::Int) is + return is + +-- | It happens that these come out in the opposite order from the Pure one: +case_show06 :: Assertion +case_show06 = assertEqual "show for SLSet" "{ISet: 44, 33}" (show show06) +show06 :: SS.ISet Frzn Int +show06 = runParThenFreeze $ do + is <- SS.newEmptySet + SS.insert (33::Int) is + SS.insert (44::Int) is + return is + +---------------------------------------- +-- Test sortFrzn instances: + +case_show05B :: Assertion +case_show05B = assertEqual "show for PureSet/Trvrsbl" "AFoldable [33, 44]" (show show05B) +show05B :: G.AFoldable Int +show05B = G.sortFrzn show05 + +case_show06B :: Assertion +case_show06B = assertEqual "show for SLSet/Trvrsbl" "AFoldable [44, 33]" (show show06B) +show06B :: G.AFoldable Int +show06B = G.sortFrzn show06 diff --git a/tests/TestHelpers.hs b/tests/TestHelpers.hs new file mode 100644 --- /dev/null +++ b/tests/TestHelpers.hs @@ -0,0 +1,383 @@ +{-# LANGUAGE BangPatterns, CPP, ScopedTypeVariables, RankNTypes #-} + +-- | To make it easier to build (multithreaded) tests + +module TestHelpers + ( + -- * Testing parameters + numElems, getNumAgents, producerRatio, + + -- * Utility for controlling the number of threads used by generated tests. + setTestThreads, + + -- * Test initialization, reading common configs + stdTestHarness, + + -- * A replacement for defaultMain that uses a 1-thread worker pool + defaultMainSeqTests, + + -- * Misc utilities + nTimes, for_, forDown_, assertOr, timeOut, assertNoTimeOut, splitRange, timeit, + theEnv, + + -- timeOutPure, + exceptionOrTimeOut, allowSomeExceptions, assertException + ) + where + +import Control.Monad +import Control.Exception +--import Control.Concurrent +--import Control.Concurrent.MVar +import GHC.Conc +import Data.IORef +import Data.Word +import Data.Time.Clock +import Data.List (isInfixOf, intersperse, nub) +import Text.Printf +import Control.Concurrent (forkOS, forkIO, ThreadId) +-- import Control.Exception (catch, SomeException, fromException, bracket, AsyncException(ThreadKilled)) +import Control.Exception (bracket) +import System.Environment (withArgs, getArgs, getEnvironment) +import System.IO (hFlush, stdout, stderr, hPutStrLn) +import System.IO.Unsafe (unsafePerformIO) +import System.Mem (performGC) +import System.Exit +import qualified Test.Framework as TF +import Test.Framework.Providers.HUnit (hUnitTestToTests) + +import Data.Monoid (mappend, mempty) +import Test.Framework.Runners.Console (interpretArgs, defaultMainWithOpts) +import Test.Framework.Runners.Options (RunnerOptions'(..)) +import Test.Framework.Options (TestOptions'(..)) +import Test.HUnit as HU + +import Debug.Trace (trace) + +-------------------------------------------------------------------------------- + + +#if __GLASGOW_HASKELL__ >= 704 +import GHC.Conc (getNumCapabilities, setNumCapabilities, getNumProcessors) +#else +import GHC.Conc (numCapabilities) +getNumCapabilities :: IO Int +getNumCapabilities = return numCapabilities + +setNumCapabilities :: Int -> IO () +setNumCapabilities = error "setNumCapabilities not supported in this older GHC! Set NUMTHREADS and +RTS -N to match." + +getNumProcessors :: IO Int +getNumProcessors = return 1 +#endif + +theEnv :: [(String, String)] +theEnv = unsafePerformIO getEnvironment + +---------------------------------------------------------------------------------------------------- +-- TODO: In addition to setting these parameters from environment +-- variables, it would be nice to route all of this through a +-- configuration record, so that it can be changed programmatically. + +-- How many elements should each of the tests pump through the queue(s)? +numElems :: Maybe Int +numElems = case lookup "NUMELEMS" theEnv of + Nothing -> Nothing -- 100 * 1000 -- 500000 + Just str -> warnUsing ("NUMELEMS = "++str) $ + Just (read str) + +forkThread :: IO () -> IO ThreadId +forkThread = case lookup "OSTHREADS" theEnv of + Nothing -> forkIO + Just x -> warnUsing ("OSTHREADS = "++x) $ + case x of + "0" -> forkIO + "False" -> forkIO + "1" -> forkOS + "True" -> forkOS + oth -> error$"OSTHREAD environment variable set to unrecognized option: "++oth + +-- | How many communicating agents are there? By default one per +-- thread used by the RTS. +getNumAgents :: IO Int +getNumAgents = case lookup "NUMAGENTS" theEnv of + Nothing -> getNumCapabilities + Just str -> warnUsing ("NUMAGENTS = "++str) $ + return (read str) + +-- | It is possible to have imbalanced concurrency where there is more +-- contention on the producing or consuming side (which corresponds to +-- settings of this parameter less than or greater than 1). +producerRatio :: Double +producerRatio = case lookup "PRODUCERRATIO" theEnv of + Nothing -> 1.0 + Just str -> warnUsing ("PRODUCERRATIO = "++str) $ + read str + +warnUsing :: String -> a -> a +warnUsing str a = trace (" [Warning]: Using environment variable "++str) a + + +-- | Dig through the test constructors to find the leaf IO actions and bracket them +-- with a thread-setting action. +setTestThreads :: Int -> HU.Test -> HU.Test +setTestThreads nm tst = loop False tst + where + loop flg x = + case x of + TestLabel lb t2 -> TestLabel (decor flg lb) (loop True t2) + TestList ls -> TestList (map (loop flg) ls) + TestCase io -> TestCase (bracketThreads nm io) + + -- We only need to insert the numcapabilities in the description string ONCE: + decor False lb = "N"++show nm++"_"++ lb + decor True lb = lb + + bracketThreads :: Int -> IO a -> IO a + bracketThreads n act = + bracket (getNumCapabilities) + setNumCapabilities + (\_ -> do dbgPrint 1 ("\n [Setting # capabilities to "++show n++" before test] \n") + setNumCapabilities n + act) + +-- | Repeat a group of tests while varying the number of OS threads used. Also, +-- read configuration info. +-- +-- WARNING: uses setNumCapabilities. +stdTestHarness :: (IO Test) -> IO () +stdTestHarness genTests = do + numAgents <- getNumAgents + putStrLn$ "Running with numElems "++show numElems++" and numAgents "++ show numAgents + putStrLn "Use NUMELEMS, NUMAGENTS, NUMTHREADS to control the size of this benchmark." + args <- getArgs + + np <- getNumProcessors + putStrLn $"Running on a machine with "++show np++" hardware threads." + + -- We allow the user to set this directly, because the "-t" based regexp selection + -- of benchmarks is quite limited. + let all_threads = case lookup "NUMTHREADS" theEnv of + Just str -> [read str] + Nothing -> nub [1, 2, np `quot` 2, np, 2*np ] + putStrLn $"Running tests for these thread settings: " ++show all_threads + all_tests <- genTests + + -- Don't allow concurent tests (the tests are concurrent!): + withArgs (args ++ ["-j1","--jxml=test-results.xml"]) $ do + + -- Hack, this shouldn't be necessary, but I'm having problems with -t: + tests <- case all_threads of + [one] -> do cap <- getNumCapabilities + unless (cap == one) $ setNumCapabilities one + return all_tests + _ -> return$ TestList [ setTestThreads n all_tests | n <- all_threads ] + TF.defaultMain$ hUnitTestToTests tests + + +---------------------------------------------------------------------------------------------------- +-- DEBUGGING +---------------------------------------------------------------------------------------------------- + +-- | Debugging flag shared by all accelerate-backend-kit modules. +-- This is activated by setting the environment variable DEBUG=1..5 +dbg :: Int +dbg = case lookup "DEBUG" theEnv of + Nothing -> defaultDbg + Just "" -> defaultDbg + Just "0" -> defaultDbg + Just s -> + trace (" ! Responding to env Var: DEBUG="++s)$ + case reads s of + ((n,_):_) -> n + [] -> error$"Attempt to parse DEBUG env var as Int failed: "++show s + +defaultDbg :: Int +defaultDbg = 0 + +-- | Print if the debug level is at or above a threshold. +dbgPrint :: Int -> String -> IO () +dbgPrint lvl str = if dbg < lvl then return () else do +-- hPutStrLn stderr str + -- hPrintf stderr str + -- hFlush stderr + printf str + hFlush stdout + +dbgPrintLn :: Int -> String -> IO () +dbgPrintLn lvl str = dbgPrint lvl (str++"\n") + + +------------------------------------------------------------------------------------------ +-- Misc Helpers +------------------------------------------------------------------------------------------ + +-- | Ensure that executing an action returns an exception +-- containing one of the expected messages. +assertException :: [String] -> IO a -> IO () +assertException msgs action = do + x <- catch (do action; return Nothing) + (\e -> do putStrLn $ "Good. Caught exception: " ++ show (e :: SomeException) + return (Just $ show e)) + case x of + Nothing -> HU.assertFailure "Failed to get an exception!" + Just s -> + if any (`isInfixOf` s) msgs + then return () + else HU.assertFailure $ "Got the wrong exception, expected one of the strings: "++ show msgs + ++ "\nInstead got this exception:\n " ++ show s + +-- | For testing quasi-deterministic programs: programs that always +-- either raise a particular exception or produce a particular answer. +allowSomeExceptions :: [String] -> IO a -> IO (Either SomeException a) +allowSomeExceptions msgs action = do + catch (do a <- action; evaluate a; return (Right a)) + (\e -> + let estr = show e in + if any (`isInfixOf` estr) msgs + then do when True $ -- (dbgLvl>=1) $ + putStrLn $ "Caught allowed exception: " ++ show (e :: SomeException) + return (Left e) + else do HU.assertFailure $ "Got the wrong exception, expected one of the strings: "++ show msgs + ++ "\nInstead got this exception:\n " ++ show estr + error "Should not reach this..." + ) + +exceptionOrTimeOut :: Show a => Double -> [String] -> IO a -> IO () +exceptionOrTimeOut time msgs action = do + x <- timeOut time $ + allowSomeExceptions msgs action + case x of + Just (Right _val) -> HU.assertFailure "exceptionOrTimeOut: action returned successfully!" + Just (Left _exn) -> return () -- Error, yay! + Nothing -> return () -- Timeout. + +-- | Simple wrapper around `timeOut` that throws an error if timeOut occurs. +assertNoTimeOut :: Show a => Double -> IO a -> IO a +assertNoTimeOut t a = do + m <- timeOut t a + case m of + Nothing -> do HU.assertFailure$ "assertNoTimeOut: thread failed or timeout occurred after "++show t++" seconds" + error "Should not reach this #2" + Just a -> return a + +-- | Time-out an IO action by running it on a separate thread, which is killed when +-- the timer (in seconds) expires. This requires that the action do allocation, otherwise it will +-- be non-preemptable. +timeOut :: Show a => Double -> IO a -> IO (Maybe a) +timeOut interval act = do + result <- newIORef Nothing + tid <- forkIO (act >>= writeIORef result . Just) + t0 <- getCurrentTime + let loop = do + stat <- threadStatus tid + case stat of + ThreadFinished -> readIORef result + ThreadBlocked r -> timeCheckAndLoop + ThreadDied -> do putStrLn " [lvish-tests] Time-out check -- thread died!" + return Nothing + ThreadRunning -> timeCheckAndLoop + timeCheckAndLoop = do + now <- getCurrentTime + let delt :: Double + delt = fromRational$ toRational$ diffUTCTime now t0 + if delt >= interval + then do putStrLn " [lvish-tests] Time-out: out of time, killing test thread.." + killThread tid + -- TODO: <- should probably wait for it to show up as dead. + return Nothing + else do threadDelay (10 * 1000) -- Sleep 10ms. + loop + loop + +{-# NOINLINE timeOutPure #-} +-- | Evaluate a pure value to weak-head normal form, with timeout. +-- This is NONDETERMINISTIC, so its type is sketchy: +-- +-- WARNING: This doesn't seem to work properly yet! I am seeing spurious failures. +-- -RRN [2013.10.24] +-- +timeOutPure :: Show a => Double -> a -> Maybe a +timeOutPure tm thnk = + unsafePerformIO (timeOut tm (evaluate thnk)) + +assertOr :: Assertion -> Assertion -> Assertion +assertOr act1 act2 = + catch act1 + (\(e::SomeException) -> act2) + + +nTimes :: Int -> (Int -> IO a) -> IO () +nTimes 0 _ = return () +nTimes n c = c n >> nTimes (n-1) c + +{-# INLINE for_ #-} +-- | Inclusive/Inclusive +for_ :: Monad m => (Int, Int) -> (Int -> m ()) -> m () +for_ (start, end) fn | start > end = forDown_ (end, start) fn +for_ (start, end) fn = loop start + where + loop !i | i > end = return () + | otherwise = do fn i; loop (i+1) + + +-- | Inclusive/Inclusive, iterate downward. +forDown_ :: Monad m => (Int, Int) -> (Int -> m ()) -> m () +forDown_ (start, end) _fn | start > end = error "forDown_: start is greater than end" +forDown_ (start, end) fn = loop end + where + loop !i | i < start = return () + | otherwise = do fn i; loop (i-1) + + +-- | Split an inclusive range into N chunks. +-- This may return less than the desired number of pieces if there aren't enough +-- elements in the range. +splitRange :: Int -> (Int,Int) -> [(Int,Int)] +splitRange pieces (start,end) + | len < pieces = [ (i,i) | i <- [start .. end]] + | otherwise = chunks + where + len = end - start + 1 + chunks = map largepiece [0..remain-1] ++ + map smallpiece [remain..pieces-1] + (portion, remain) = len `quotRem` pieces + largepiece i = + let offset = start + (i * (portion + 1)) + in (offset, (offset + portion)) + smallpiece i = + let offset = start + (i * portion) + remain + in (offset, (offset + portion - 1)) + +-- | Print out a SELFTIMED message reporting the time from a given test. +timeit :: IO a -> IO a +timeit ioact = do + start <- getCurrentTime + res <- ioact + end <- getCurrentTime + putStrLn$ "SELFTIMED: " ++ show (diffUTCTime end start) + return res + +-- | An alternate version of `defaultMain` which sets the number of test running +-- threads to one by default, unless the user explicitly overrules it with "-j". +defaultMainSeqTests :: [TF.Test] -> IO () +defaultMainSeqTests tests = do + putStrLn " [*] Default test harness..." + args <- getArgs + x <- interpretArgs args + res <- try (case x of + Left err -> error$ "defaultMainSeqTests: "++err + Right (opts,_) -> do let opts' = ((mempty{ ropt_threads= Just 1 + , ropt_test_options = Just (mempty{ topt_timeout=(Just$ Just$ 3*1000*1000)})}) + `mappend` opts) + putStrLn $ " [*] Using "++ show (ropt_threads opts')++ " worker threads for testing." + defaultMainWithOpts tests opts' + ) + case res of + Left (e::ExitCode) -> do + putStrLn$ " [*] test-framework exiting with: "++show e + performGC + putStrLn " [*] GC finished on main thread." + threadDelay (30 * 1000) + putStrLn " [*] Main thread exiting." + exitWith e diff --git a/unit-tests.hs b/unit-tests.hs deleted file mode 100644 --- a/unit-tests.hs +++ /dev/null @@ -1,1200 +0,0 @@ -{-# LANGUAGE TemplateHaskell, CPP, ScopedTypeVariables #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE NamedFieldPuns #-} - -module Main where - -import Test.Framework.Providers.HUnit -import Test.Framework (Test, defaultMain, testGroup) --- [2013.09.26] Temporarily disabling template haskell due to GHC bug discussed here: --- https://github.com/rrnewton/haskell-lockfree/issues/10 --- import Test.Framework.TH (testGroupGenerator, defaultMainGenerator) - -import Test.HUnit (Assertion, assertEqual, assertBool, Counts(..)) -import qualified Test.HUnit as HU -import Control.Applicative -import Control.Monad -import Control.Concurrent -import Control.Concurrent.MVar -import GHC.Conc -import Data.List (isInfixOf, intersperse) -import qualified Data.Vector as V -import qualified Data.Set as S -import Data.IORef -import Data.Time.Clock -import System.Environment (getArgs) -import System.IO -import System.Exit -import System.Random - -import Control.Exception (catch, evaluate, SomeException) - -import Data.Traversable (traverse) -import qualified Data.Set as S -import qualified Data.Map as M -import Data.Word - -import qualified Data.LVar.Generic as G -#ifdef NATARRAY -import qualified Data.LVar.NatArray as NA -#endif -import Data.LVar.PureSet as IS -import Data.LVar.PureMap as IM - -import qualified Data.LVar.SLMap as SM -import qualified Data.LVar.SLSet as SS - -import qualified Data.LVar.IVar as IV -import qualified Data.LVar.IStructure as ISt -import qualified Data.LVar.Pair as IP - -import Control.LVish -import Control.LVish.DeepFrz (DeepFrz(..), Frzn, Trvrsbl, runParThenFreeze, runParThenFreezeIO) -import qualified Control.LVish.Internal as I -import Control.LVish.SchedIdempotent (liftIO, dbgLvl, forkWithExceptions) -import qualified Control.LVish.SchedIdempotent as L - -import qualified Data.Concurrent.SNZI as SNZI -import qualified Data.Concurrent.LinkedMap as LM -import qualified Data.Concurrent.SkipListMap as SLM - -import TestHelpers as T - --------------------------------------------------------------------------------- - --- Disabling thread-variation due to below bug: -#if 1 --- EEK! Just got this [2013.06.27]: --- --- unit-tests.exe: internal error: wakeup_gc_threads --- (GHC version 7.6.3 for x86_64_unknown_linux) --- Please report this as a GHC bug: http://www.haskell.org/ghc/reportabug --- Aborted (core dumped) - -main :: IO () -main = do - -- T.stdTestHarness $ return all_tests -- Version that varies threads. - if True then -- Use test-framework: - defaultMain $ hUnitTestToTests all_tests - else do - -- Counts{errors,failures} <- HU.runTestTT all_tests - (Counts{errors,failures},_) <- HU.runTestText (HU.putTextToHandle stdout False) all_tests - if errors+failures == 0 then exitSuccess else exitFailure - - where - all_tests :: HU.Test - all_tests = - HU.TestList - [ HU.TestLabel "case_v0" $ HU.TestCase case_v0 - , HU.TestLabel "case_v1a" $ HU.TestCase case_v1a - , HU.TestLabel "case_v1b" $ HU.TestCase case_v1b - , HU.TestLabel "case_v2a" $ HU.TestCase case_v2a - , HU.TestLabel "case_v2b" $ HU.TestCase case_v2b -- livelock? [2013.09.26] --- , HU.TestLabel "case_v3a" $ HU.TestCase case_v3a - , HU.TestLabel "case_v3b" $ HU.TestCase case_v3b - , HU.TestLabel "case_i3c" $ HU.TestCase case_i3c - , HU.TestLabel "case_v3d" $ HU.TestCase case_v3d - , HU.TestLabel "case_v3e" $ HU.TestCase case_v3e - , HU.TestLabel "case_i3f" $ HU.TestCase case_i3f - , HU.TestLabel "case_i3g" $ HU.TestCase case_i3g - , HU.TestLabel "case_v7a" $ HU.TestCase case_v7a - , HU.TestLabel "case_i7b" $ HU.TestCase case_i7b - , HU.TestLabel "case_v7c" $ HU.TestCase case_v7c - , HU.TestLabel "case_v8a" $ HU.TestCase case_v8a - , HU.TestLabel "case_v8b" $ HU.TestCase case_v8b - , HU.TestLabel "case_v8c" $ HU.TestCase case_v8c - , HU.TestLabel "case_v8d" $ HU.TestCase case_v8d -#ifdef NATARRAY - , HU.TestLabel "case_v9a" $ HU.TestCase case_v9a - , HU.TestLabel "case_i9c" $ HU.TestCase case_i9c - , HU.TestLabel "case_v9d" $ HU.TestCase case_v9d - , HU.TestLabel "case_v9e" $ HU.TestCase case_v9e --- , HU.TestLabel "case_v9f" $ HU.TestCase case_v9f -- [2013.09.26] RRN: problems.. - , HU.TestLabel "case_i9h" $ HU.TestCase case_i9h -#endif - , HU.TestLabel "case_lp01" $ HU.TestCase case_lp01 - , HU.TestLabel "case_lp02" $ HU.TestCase case_lp02 - , HU.TestLabel "case_lp03" $ HU.TestCase case_lp03 - , HU.TestLabel "case_lp04" $ HU.TestCase case_lp04 - - -- [2013.09.26] RRN: Disabling for now. We don't depend on them yet and they are - -- exhibiting bugs: - -- , HU.TestLabel "case_snzi1" $ HU.TestCase case_snzi1 - -- , HU.TestLabel "case_snzi2" $ HU.TestCase case_snzi2 - -- , HU.TestLabel "case_snzi3" $ HU.TestCase case_snzi3 - -- , HU.TestLabel "case_snzi4 " $ HU.TestCase case_snzi4 - , HU.TestLabel "case_lm1" $ HU.TestCase case_lm1 - , HU.TestLabel "case_slm1" $ HU.TestCase case_slm1 - , HU.TestLabel "case_slm2" $ HU.TestCase case_slm2 - , HU.TestLabel "case_dftest0" $ HU.TestCase case_dftest0 - , HU.TestLabel "case_dftest1" $ HU.TestCase case_dftest1 - , HU.TestLabel "case_dftest3" $ HU.TestCase case_dftest3 - - , HU.TestLabel "case_show01" $ HU.TestCase case_show01 - , HU.TestLabel "case_show02" $ HU.TestCase case_show02 - , HU.TestLabel "case_show03" $ HU.TestCase case_show03 - , HU.TestLabel "case_show04" $ HU.TestCase case_show04 - , HU.TestLabel "case_show05" $ HU.TestCase case_show05 - , HU.TestLabel "case_show06" $ HU.TestCase case_show06 - - , HU.TestLabel "case_show05B" $ HU.TestCase case_show05B - , HU.TestLabel "case_show06B" $ HU.TestCase case_show06B - ] - -- Ugh, busted test bracketing in test-framework... thus no good way to do - -- thread-parameterization and no good way to take advantage of test-framework-th: - -- $(testGroupGenerator) -#else --- This is what we would do if not for the atomic-primops triggered GHC linking bug: -main :: IO () -main = $(defaultMainGenerator) -#endif - -case_v0 :: HU.Assertion -case_v0 = do res <- v0 - HU.assertEqual "useless fork" (4::Int) res -v0 = runParIO $ do i <- IV.new; fork (return ()); IV.put i 4; IV.get i - - -case_v1a :: Assertion -case_v1a = assertEqual "fork put" (4::Int) =<< v1a -v1a :: IO Int -v1a = runParIO $ do i<-IV.new; fork (IV.put i 4); IV.get i - -case_v1b :: Assertion -case_v1b = do ls <- v1b - case length ls of - 0 -> return () -- Ok, i guess debugging is off. - 1 -> return () - _ -> error $ "Wrong number of log messages: \n" ++ concat (intersperse "\n" ls) - --- | In this sequential case there should be no data-race, and thus no duplication of the callback. -v1b :: IO [String] -v1b = do let tag = "callback on ivar " - (logs,_) <- runParLogged $ do - i <- IV.new - IV.put i (3::Int) - IV.whenFull Nothing i (\x -> logStrLn$ tag++show x) - IV.put i 3 - IV.put i 3 - return () - mapM_ putStrLn logs - return (filter (isInfixOf tag) logs) - --- v1c - -case_v2a :: Assertion -case_v2a = v2a >>= assertEqual "put 10 in & wait" - (S.fromList [1..10] :: S.Set Int) - --- [2013.06.27] getting thread-blocked-indefinitely errors: -v2a :: IO (S.Set Int) -v2a = runParIO $ - do s <- IS.newEmptySet - mapM_ (\n -> fork $ IS.insert n s) [1..10] - IS.waitSize 10 s - IS.freezeSet s - --- | This version uses a fork-join so it doesn't need the waitSize: -case_v2b :: Assertion -case_v2b = v2b >>= assertEqual "t2 with spawn instead of fork" - (S.fromList [1..10] :: S.Set Int) - -v2b :: IO (S.Set Int) -v2b = runParIO $ - do s <- IS.newEmptySet - ivs <- mapM (\n -> IV.spawn_ $ IS.insert n s) [1..10] - mapM_ IV.get ivs -- Join point. - IS.freezeSet s - --- FIMXE: - --- | This version uses deep freeze. -case_v2c :: Assertion -case_v2c = assertEqual "t2 with spawn instead of fork" - (S.fromList [1..10] :: S.Set Int) - (IS.fromISet v2c) - --- v2c :: S.Set Int -v2c :: IS.ISet Frzn Int -v2c = -- IS.fromISet $ - runParThenFreeze par - where - par :: Par Det s (IS.ISet s Int) - par = - do s <- IS.newEmptySet - ivs <- mapM (\n -> IV.spawn_ $ IS.insert n s) [1..10::Int] - mapM_ IV.get ivs -- Join point. - return s - -escape01 :: IV.IVar Frzn Int -escape01 = runParThenFreeze $ do v <- IV.new; IV.put v (3::Int); return v - --- | This is VERY BAD: -escape01B :: Par d Frzn String -escape01B = - do IV.put escape01 (4::Int) - return "uh oh" - --- | [2013.10.06] Fixed this by requiring a SPECIFIC type, NonFrzn. --- major_bug :: String --- major_bug = runParThenFreeze escape01B - --- | Simple callback test. --- case_v3a :: Assertion --- case_v3a = v3a >>= assertEqual "simple callback test" --- (S.fromList [10,20,30,40,50,60,70,80,90,100] :: S.Set Int) - --- [2013.06.27] This is failing just occasionally with a multiple-put: -v3a :: IO (S.Set Int) -v3a = runParIO $ - do s1 <- IS.newEmptySet - s2 <- IS.newEmptySet - let fn e = IS.insert (e*10) s2 - IS.withCallbacksThenFreeze s1 fn $ do - -- Populate the first set: - mapM_ (\n -> fork $ IS.insert n s1) [1..10] - -- We never read out of s1 directly. Instead, writes to s1 trigger the - -- callback 'fn' to run, with the element written to s2. So eventually, - -- ten elements are written to s2. - IS.waitSize 10 s2 - IS.freezeSet s2 - -case_v3b :: Assertion -case_v3b = v3b >>= assertEqual "simple callback test" - (S.fromList [10,20,30,40,50,60,70,80,90,100] :: S.Set Int) - -v3b :: IO (S.Set Int) -v3b = runParIO $ - do s1 <- IS.newEmptySet - s2 <- IS.newEmptySet - let fn e = IS.insert (e*10) s2 - IS.withCallbacksThenFreeze s1 fn $ do - -- Populate the first set: - mapM_ (\n -> IS.insert n s1) [1..10] - -- Because we filled s1 sequentially, we know it is full at this point. - -- (If the above were forked we would need a finish/asnyc style construct) - - -- After all of s1's callbacks are finished executing, s2 is full: - IS.freezeSet s2 - - --- | An under-synchronized test. This should always return the same --- result OR throw an exception. In this case it should always return --- a list of 10 elements, or throw an exception. -case_i3c :: Assertion -case_i3c = do - allowSomeExceptions ["Attempt to change a frozen LVar"] $ - do x <- i3c - assertEqual "under-synchronized passed through" - (S.fromList [10,20..100] :: S.Set Int) x - return () - -i3c :: IO (S.Set Int) -i3c = runParIO $ - do s1 <- IS.newEmptySet - s2 <- IS.newEmptySet - let fn e = IS.insert (e*10) s2 - IS.withCallbacksThenFreeze s1 fn $ do - mapM_ (\n -> fork $ IS.insert n s1) [1..10] - IS.waitSize 1 s2 -- Not ENOUGH synchronization! - IS.freezeSet s2 - -- If this ^ freeze occurs *before* all the puts have happened, - -- the a put happening after it will throw an exception. If, - -- on the other hand, it occurs after they've all happened, - -- then we won't notice that anything is wrong and we'll get - -- the same result we would have in case_v3. - --- FIXME: currently if run enough times, i3c can get the following failure: --- I think we need to use full Async's so the cancellation goes both ways: - - -- Main: - -- Exception inside child thread "worker thread", ThreadId 12: Attempt to change a frozen LVar - -- Exception inside child thread "worker thread", ThreadId 9: Attempt to change a frozen LVar - -- Exception inside child thread "worker thread", ThreadId 11: Attempt to change a frozen LVar - -- test-lvish: Attempt to change a frozen LVar - -- Exception inside child thread "worker thread", ThreadId 10: thread blocked indefinitely in an MVar operation - - -case_v3d :: Assertion -case_v3d = assertEqual "test of parallelism in freezeSetAfter" - (S.fromList [1..5]) =<< v3d - --- | This test has interdependencies between callbacks (that are launched on --- already-present data), which forces these to be handled in parallel. -v3d :: IO (S.Set Int) -v3d = runParIO $ - do s1 <- IS.newFromList [1..5] - s2 <- IS.newEmptySet - IS.freezeSetAfter s1 $ \ elm -> do - let dep = case elm of - 1 -> Just 2 - 2 -> Just 3 - 3 -> Nothing -- Foil either left-to-right or right-to-left - 4 -> Just 3 - 5 -> Just 4 - case dep of - Nothing -> logStrLn $ " [Invocation "++show elm++"] has no dependencies, running... " - Just d -> do logStrLn $ " [Invocation "++show elm++"] waiting on "++show dep - IS.waitElem d s2 - logStrLn $ " [Invocation "++show elm++"] dependency satisfied! " - IS.insert elm s2 - logStrLn " [freezeSetAfter completed] " - freezeSet s2 - -case_v3e :: Assertion -case_v3e = assertEqual "test of parallelism in forEachHP" - (S.fromList [1..5]) =<< v3e - --- | Same as v3d but for forEachHP -v3e :: IO (S.Set Int) -v3e = runParIO $ IS.freezeSet =<< - do s1 <- IS.newFromList [1..5] - s2 <- IS.newEmptySet - hp <- newPool - IS.forEachHP (Just hp) s1 $ \ elm -> do - let dep = case elm of - 1 -> Just 2 - 2 -> Just 3 - 3 -> Nothing -- Foil either left-to-right or right-to-left - 4 -> Just 3 - 5 -> Just 4 - case dep of - Nothing -> logStrLn $ " [Invocation "++show elm++"] has no dependencies, running... " - Just d -> do logStrLn $ " [Invocation "++show elm++"] waiting on "++show dep - IS.waitElem d s2 - logStrLn $ " [Invocation "++show elm++"] dependency satisfied! " - IS.insert elm s2 - quiesce hp - logStrLn " [quiesce completed] " - return s2 - --- RRN: Currently we have a policy where leaving the seen with running threads is --- disallowed, but blocked ones are tolerated. -case_i3f :: Assertion -case_i3f = exceptionOrTimeOut 0.3 ["test switched off"] i3f -#ifdef NO_DANGLING_THREADS --- | A test to make sure that we get an error when we block on an unavailable ivar. -i3f :: IO () -i3f = runParIO$ do - iv <- IV.new - fork $ do IV.get iv - logStrLn "Unblocked! Shouldn't see this." - return () - return () -#else -i3f = error "test switched off" -#endif - -case_i3g :: Assertion -case_i3g = exceptionOrTimeOut 0.3 [] i3g --- | A still-running worker thread should NOT be allowed, because it may do a put that causes an exception. -i3g :: IO Word8 -i3g = runParIO$ do - iv <- IV.new - fork $ do let loop !ls = loop [1 .. length ls] - loop [1..10] - return 9 - - -case_v7a :: Assertion -case_v7a = assertEqual "basic imap test" - (M.fromList [(1,1.0),(2,2.0),(3,3.0),(100,100.1),(200,201.1)]) =<< - v7a - -v7a :: IO (M.Map Int Float) -v7a = runParIO $ IM.freezeMap =<< - do mp <- IM.newEmptyMap - fork $ do IM.waitSize 3 mp - IM.insert 100 100.1 mp - fork $ do IM.waitValue 100.1 mp - v <- IM.getKey 1 mp - IM.insert 200 (200.1 + v) mp - IM.insert 1 1 mp - IM.insert 2 2 mp - logStrLn "[v7a] Did the first two puts.." - I.liftIO$ threadDelay 1000 - IM.insert 3 3 mp - logStrLn "[v7a] Did the first third put." - IM.waitSize 5 mp - return mp - --- [2013.08.05] RRN: Observing nondeterministic blocked-indefinitely --- exception here. -case_i7b :: Assertion -case_i7b = do - allowSomeExceptions ["Multiple puts"] $ - assertEqual "racing insert and modify" - (M.fromList [(1,S.fromList [3.33]), - (2,S.fromList [0.11,4.44])]) =<< - i7b - return () - --- | A quasi-deterministic example. -i7b :: IO (M.Map Int (S.Set Float)) --- Do we need a "deep freeze" that freezes nested structures? -i7b = runParIO $ do - mp <- IM.newEmptyMap - s1 <- IS.newEmptySet - s2 <- IS.newEmptySet - IS.insert 0.11 s2 - f1 <- IV.spawn_ $ do IM.insert 1 s1 mp - IM.insert 2 s2 mp - f2 <- IV.spawn_ $ do s <- IM.getKey 1 mp - IS.insert 3.33 s - -- RACE: this modify is racing with the insert of s2: - IM.modify mp 2 IS.newEmptySet (IS.insert 4.44) - - IV.get f1; IV.get f2 - mp2 <- IM.freezeMap mp - traverse IS.freezeSet mp2 - -case_v7c :: Assertion -case_v7c = assertEqual "imap test - racing modifies" - (M.fromList [(1,S.fromList [3.33]), - (2,S.fromList [4.44]), - (3,S.fromList [5.55,6.6])]) =<< - v7c - --- | This example is valid because two modifies may race. -v7c :: IO (M.Map Int (S.Set Float)) --- Do we need a "deep freeze" that freezes nested structures? -v7c = runParIO $ do - mp <- IM.newEmptyMap - s1 <- IS.newEmptySet - f1 <- IV.spawn_ $ IM.insert 1 s1 mp - f2 <- IV.spawn_ $ do s <- IM.getKey 1 mp - IS.insert 3.33 s - IM.modify mp 2 IS.newEmptySet (IS.insert 4.44) - f3 <- IV.spawn_ $ IM.modify mp 3 IS.newEmptySet (IS.insert 5.55) - f4 <- IV.spawn_ $ IM.modify mp 3 IS.newEmptySet (IS.insert 6.6) - -- No easy way to wait on the total size of all contained sets... - -- - -- Need a barrier here.. should have a monad-transformer that provides cilk "sync" - -- Global quiesce is convenient too.. - IV.get f1; IV.get f2; IV.get f3; IV.get f4 - mp2 <- IM.freezeMap mp - traverse IS.freezeSet mp2 - --------------------------------------------------------------------------------- --- Higher level derived ops --------------------------------------------------------------------------------- - -case_v8a :: Assertion -case_v8a = assertEqual "simple cartesian product test" - (S.fromList - [(1,'a'),(1,'b'),(1,'c'), - (2,'a'),(2,'b'),(2,'c'), - (3,'a'),(3,'b'),(3,'c')]) - =<< v8a - --- v8a :: IO (S.Set (Integer, Char)) -v8a :: IO (S.Set (Integer, Char)) -v8a = runParIO $ do - s1 <- IS.newFromList [1,2,3] - s2 <- IS.newFromList ['a','b'] - logStrLn " [v8a] now to construct cartesian product..." - h <- newPool - s3 <- IS.cartesianProdHP (Just h) s1 s2 - logStrLn " [v8a] cartesianProd call finished... next quiesce" - IS.forEach s3 $ \ elm -> - logStrLn$ " [v8a] Got element: "++show elm - IS.insert 'c' s2 - quiesce h - logStrLn " [v8a] quiesce finished, next freeze::" - freezeSet s3 - -case_v8b :: Assertion -case_v8b = assertEqual "3-way cartesian product" - (S.fromList - [[1,40,101],[1,40,102], [1,50,101],[1,50,102], - [2,40,101],[2,40,102], [2,50,101],[2,50,102]] - ) - =<< v8b - -v8b :: IO (S.Set [Int]) -v8b = runParIO $ do - hp <- newPool - s1 <- IS.newFromList [1,2] - s2 <- IS.newFromList [40,50] - -- (hp,s3) <- IS.traverseSetHP Nothing (return . (+100)) s1 - s3 <- IS.traverseSetHP (Just hp) (return . (+100)) s1 - s4 <- IS.cartesianProdsHP (Just hp) [s1,s2,s3] - IS.forEachHP (Just hp) s4 $ \ elm -> - logStrLn $ " [v8b] Got element: "++show elm - -- [2013.07.03] Confirmed: this makes the bug(s) go away: - -- liftIO$ threadDelay$ 100*1000 - quiesce hp - logStrLn " [v8b] quiesce finished, next freeze::" - freezeSet s4 - -case_v8c :: Assertion -case_v8c = assertEqual "forEachHP on maps" - (M.fromList [(1,101),(2,102)] ) =<< v8c - --- | Similar test with Maps instead of Sets. -v8c :: IO (M.Map Int Int) -v8c = runParIO $ do - hp <- newPool - m1 <- IM.newFromList [(1,1),(2,2)] - m2 <- newEmptyMap - let cb k v = do logStrLn$" [v8c] Inside callback for Map.. key="++show k - IM.insert k (v+100) m2 - IM.forEachHP (Just hp) m1 cb - logStrLn " [v8c] Everything set up; about to quiesce..." - quiesce hp - logStrLn " [v8c] quiesce finished, next freeze:" - freezeMap m2 - - -case_v8d :: Assertion -case_v8d = assertEqual "union on maps" - (M.fromList [(1,101),(2,102),(40,40),(50,50)] ) - =<< v8d -v8d :: IO (M.Map Int Int) -v8d = runParIO $ do - hp <- newPool - logStrLn " [v8d] Got a new pool..." - m1 <- IM.newFromList [(1,1),(2,2)] - m2 <- IM.newFromList [(40,40),(50,50)] - logStrLn " [v8d] Got two fresh maps..." - let cb k v = do logStrLn$" [v8d] Inside callback for traverse.. key="++show k - return (v+100) - m3 <- IM.traverseMapHP (Just hp) cb m1 - m4 <- IM.unionHP (Just hp) m2 m3 - IM.forEachHP (Just hp) m4 $ \ k elm -> - logStrLn $ " [v8d] Got element: "++show (k,elm) - logStrLn " [v8d] Everything set up; about to quiesce..." - quiesce hp --- quiesceAll - logStrLn " [v8d] quiesce finished, next freeze::" - freezeMap m4 - --------------------------------------------------------------------------------- --- NatArrays --------------------------------------------------------------------------------- - -#ifdef NATARRAY -case_v9a :: Assertion -case_v9a = assertEqual "basic NatArray" 4 =<< v9a -v9a :: IO Word8 -v9a = runParIO$ do - arr <- NA.newNatArray 10 - NA.put arr 5 (4::Word8) - NA.get arr 5 - - --- #ifdef NO_DANGLING_THREADS --- case_i9b :: Assertion --- case_i9b = exceptionOrTimeOut 0.3 [] i9b --- -- | A test to make sure that we get an error when we should. --- i9b :: IO Word8 --- i9b = runParIO$ do --- arr:: NA.NatArray s Word8 <- NA.newNatArray 10 --- fork $ do NA.get arr 5 --- logStrLn "Unblocked! Shouldn't see this." --- return () --- return 9 --- #endif - -case_i9c :: Assertion -case_i9c = exceptionOrTimeOut 0.3 ["thread blocked indefinitely"] i9c -i9c :: IO Word8 -i9c = runParIO$ do - arr:: NA.NatArray s Word8 <- NA.newNatArray 10 - fork $ do NA.get arr 5 - logStrLn "Unblocked! Shouldn't see this." - NA.put arr 6 99 - NA.get arr 6 - -case_v9d :: Assertion -case_v9d = assertEqual "NatArray blocking/unblocking" 99 =<< v9d -v9d :: IO Word8 -v9d = runParIO$ do - arr:: NA.NatArray s Word8 <- NA.newNatArray 10 - fork $ do NA.get arr 5 - logStrLn "Unblocked! Good." - NA.put arr 6 99 - logStrLn "After fork." - NA.put arr 5 5 - NA.get arr 6 - --- WARNING: I'm seeing some livelocks here that depend on the number of threads --- (e.g. at -N4 but not -N2). When deadlocked on -N4 it burns 250% cpu. --- --- [2013.08.05] Update... it can pass 100 iterations at -N4 BY ITSELF, --- but fails much more rapidly when run together with other 'v9' --- tests. -case_v9e :: Assertion - -case_v9e = assertEqual "Scale up a bit" 5000050000 =<< v9e -v9e :: IO Word64 -v9e = runParIO$ do - let size = 100000 - arr <- NA.newNatArray size - fork $ - forM_ [0..size-1] $ \ix -> - NA.put arr ix (fromIntegral ix + 1) -- Can't put 0 - logStrLn "After fork." - let loop !acc ix | ix == size = return acc - | otherwise = do v <- NA.get arr ix - loop (acc+v) (ix+1) - loop 0 0 --- NOTE: this test takes about 0.03 seconds. --- It is not faster with two threads, alas... but it is higher variance! - --- | Here's the same test with an actual array of IVars. --- This one is reliable, but takes about 0.20-0.30 seconds. -case_v9f :: Assertion --- [2013.08.05] RRN: Actually I'm seeing the same non-deterministic --- thread-blocked-indefinitely problem here. -case_v9f = assertEqual "Array of ivars, compare effficiency:" 5000050000 =<< v9f -v9f :: IO Word64 -v9f = runParIO$ do - let size = 100000 - news = V.replicate size IV.new - arr <- V.sequence news - fork $ - forM_ [0..size-1] $ \ix -> - IV.put_ (arr V.! ix) (fromIntegral ix + 1) - logStrLn "After fork." - let loop !acc ix | ix == size = return acc - | otherwise = do v <- IV.get (arr V.! ix) - loop (acc+v) (ix+1) - loop 0 0 - --- Uh oh, this is blocking indefinitely sometimes... --- BUT, only when I run the whole test suite.. via cabal install --enable-tests -case_i9h :: Assertion -case_i9h = exceptionOrTimeOut 0.3 ["Attempt to put zero"] i9i -i9i :: IO Word -i9i = runParIO$ do - arr <- NA.newNatArray 1 - NA.put arr 0 0 - NA.get arr 0 - -#endif --- end: NatArray tests - --- | One more time with a full IStructure. -case_v9g :: Assertion -case_v9g = assertEqual "IStructure, compare effficiency:" 5000050000 =<< v9g -v9g :: IO Word64 -v9g = runParIO$ do - let size = 100000 - arr <- ISt.newIStructure size - fork $ - forM_ [0..size-1] $ \ix -> - ISt.put_ arr ix (fromIntegral ix + 1) - logStrLn "After fork." - let loop !acc ix | ix == size = return acc - | otherwise = do v <- ISt.get arr ix - loop (acc+v) (ix+1) - loop 0 0 - - --------------------------------------------------------------------------------- --- Looping constructs --------------------------------------------------------------------------------- - -case_lp01 :: Assertion -case_lp01 = assertEqual "parForSimple test" "done" =<< lp01 -lp01 = runParIO$ do - logStrLn " [lp01] Starting parForSimple loop..." - x <- IV.new - parForSimple (0,10) $ \ ix -> do - logStrLn$ " [lp01] iter "++show ix - when (ix == 9)$ IV.put x "done" - IV.get x - -case_lp02 :: Assertion -case_lp02 = assertEqual "parForL test" "done" =<< lp02 -lp02 = runParIO$ do - logStrLn " [lp02] Starting parForL loop..." - x <- IV.new - parForL (0,10) $ \ ix -> do - logStrLn$ " [lp02] iter "++show ix - when (ix == 9)$ IV.put x "done" - logStrLn$ " [lp02] after loop..." - IV.get x - --- [2013.08.05] RRN: I'm seeing this hang sometimes. It live-locks --- burning CPU. (But only 170% CPU with -N4.) Hmm, I can't get it to --- freeze running BY ITSELF, however. In fact I can't get the problem --- while running just the "lp" tests. I can get the problem running --- just 'v' tests and even just 'v9' tests. -case_lp03 :: Assertion -case_lp03 = assertEqual "parForTree test" "done" =<< lp03 -lp03 = runParIO$ do - logStrLn " [lp03] Starting parForTree loop..." - x <- IV.new - parForTree (0,10) $ \ ix -> do - logStrLn$ " [lp03] iter "++show ix - when (ix == 9)$ IV.put x "done" - logStrLn$ " [lp03] after loop..." - IV.get x - -case_lp04 :: Assertion -case_lp04 = assertEqual "parForTree test" "done" =<< lp04 -lp04 = runParIO$ do - logStrLn " [lp04] Starting parForTiled loop..." - x <- IV.new - parForTiled 16 (0,10) $ \ ix -> do - logStrLn$ " [lp04] iter "++show ix - when (ix == 9)$ IV.put x "done" - logStrLn$ " [lp04] after loop..." - IV.get x - - --------------------------------------------------------------------------------- --- TESTS FOR SNZI --------------------------------------------------------------------------------- - --- | Test snzi in a sequential setting -snzi1 :: IO (Bool) -snzi1 = do - (cs, poll) <- SNZI.newSNZI - forM_ cs SNZI.arrive - forM_ cs SNZI.arrive - forM_ cs SNZI.depart - forM_ cs SNZI.depart - poll - -case_snzi1 :: Assertion -case_snzi1 = snzi1 >>= assertEqual "sequential use of SNZI" True - --- | Very simple sequential snzi test -snzi2a :: IO (Bool) -snzi2a = do - (cs, poll) <- SNZI.newSNZI - forM_ cs SNZI.arrive - poll - -case_snzi2a :: Assertion -case_snzi2a = snzi2a >>= assertEqual "sequential use of SNZI" False - --- | Test snzi in a sequential setting -snzi2 :: IO (Bool) -snzi2 = do - (cs, poll) <- SNZI.newSNZI - forM_ cs SNZI.arrive - forM_ cs SNZI.arrive - forM_ cs SNZI.depart - forM_ cs SNZI.depart - forM_ cs SNZI.arrive - poll - -case_snzi2 :: Assertion -case_snzi2 = snzi2 >>= assertEqual "sequential use of SNZI" False - --- | Test snzi in a concurrent setting -snzi3 :: IO (Bool) -snzi3 = do - (cs, poll) <- SNZI.newSNZI - mvars <- forM cs $ \c -> do - mv <- newEmptyMVar - forkWithExceptions forkIO "snzi3 test thread" $ do - nTimes 1000000 $ \_ -> do - SNZI.arrive c - SNZI.depart c - SNZI.arrive c - SNZI.arrive c - SNZI.depart c - SNZI.depart c - putMVar mv () - return mv - forM_ mvars takeMVar - poll - -case_snzi3 :: Assertion -case_snzi3 = snzi3 >>= assertEqual "concurrent use of SNZI" True - --- | Test snzi in a concurrent setting -snzi4 :: IO (Bool) -snzi4 = do - (cs, poll) <- SNZI.newSNZI - mvars <- forM cs $ \c -> do - mv <- newEmptyMVar - internalMV <- newEmptyMVar - forkWithExceptions forkIO "snzi4 test thread type A" $ do - SNZI.arrive c - putMVar internalMV () - forkWithExceptions forkIO "snzi4 test thread type B" $ do - nTimes 1000000 $ \_ -> do - SNZI.arrive c - SNZI.depart c - SNZI.arrive c - SNZI.arrive c - SNZI.depart c - SNZI.depart c - takeMVar internalMV - putMVar mv () - return mv - forM_ mvars takeMVar - poll - -case_snzi4 :: Assertion -case_snzi4 = snzi4 >>= assertEqual "concurrent use of SNZI" False - --------------------------------------------------------------------------------- --- TESTS FOR SKIPLIST --------------------------------------------------------------------------------- - -lm1 :: IO (String) -lm1 = do - lm <- LM.newLMap - LM.NotFound tok <- LM.find lm 1 - LM.tryInsert tok "Hello" - LM.NotFound tok <- LM.find lm 0 - LM.tryInsert tok " World" - LM.Found s1 <- LM.find lm 1 - LM.Found s0 <- LM.find lm 0 - return $ s1 ++ s0 - -case_lm1 :: Assertion -case_lm1 = lm1 >>= assertEqual "test sequential insertion for LinkedMap" "Hello World" - -slm1 :: IO (String) -slm1 = do - slm <- SLM.newSLMap 5 - SLM.putIfAbsent slm 0 $ return "Hello " - SLM.putIfAbsent slm 1 $ return "World" - Just s0 <- SLM.find slm 0 - Just s1 <- SLM.find slm 1 - return $ s0 ++ s1 - -case_slm1 :: Assertion -case_slm1 = slm1 >>= assertEqual "test sequential insertion for SkipListMap" "Hello World" - -slm2 :: IO Bool -slm2 = do - slm <- SLM.newSLMap 10 - mvars <- replicateM numCapabilities $ do - mv <- newEmptyMVar - forkWithExceptions forkIO "slm2 test thread" $ do - rgen <- newIORef $ mkStdGen 0 - let flip = do - g <- readIORef rgen - let (b, g') = random g - writeIORef rgen $! g' - return b - nTimes 10000 $ \n -> SLM.putIfAbsentToss slm n (return n) flip - putMVar mv () - return mv - forM_ mvars takeMVar - -- cs <- SLM.counts slm - -- putStrLn $ show cs - SLM.foldlWithKey (\b k v -> if k == v then return b else return False) True slm --- Just n <- SLM.find slm (slm2Count/2) -- test find function --- return n - -case_slm2 :: Assertion -case_slm2 = slm2 >>= assertEqual "test concurrent insertion for SkipListMap" True - --------------------------------------------------------------------------------- --- TEMPLATE HASKELL BUG? -- if we have *block* commented case_foo decls, it detects --- those when it shouldn't: --------------------------------------------------------------------------------- - --- -- | Simple test of pairs. --- case_v4 :: Assertion --- case_v4 = v4 >>= assertEqual "simple-pair" (3, "hi") - --- v4 :: IO (Int,String) --- v4 = runParIO $ --- do p <- newPair --- putFst p 3 --- putSnd p "hi" --- x <- getFst p --- y <- getSnd p --- return (x,y) - --- -- | This program should throw an exception due to multiple puts. --- case_i5a :: Assertion --- case_i5a = assertException ["Multiple puts to an IVar!"] i5a - --- i5a :: IO Int --- i5a = runParIO ( --- do p <- newPair --- putFst p 3 --- putSnd p "hi" --- putSnd p "there" --- getFst p) - --- -- | Another exception due to multiple puts. This tests whether the scheduler waits --- -- around for a trailing (errorful) computation that is not on the main thread. --- case_i5b :: Assertion --- case_i5b = assertException ["Multiple puts to an IVar!"] i5b - --- i5b = --- runParIO $ --- do p <- newPair --- putFst p 3 --- putSnd p "hi" --- fork $ do waste_time --- putSnd p "there" --- -- There's no 'consume' here; so we should really just get a --- -- "Multiple puts to an IVar!" exception. --- getSnd p - --- -- | Similar to 5b but with the branches flipped. --- case_i5c :: Assertion --- case_i5c = assertException ["Multiple puts to an IVar!"] i5c - --- i5c = runParIO $ --- do p <- newPair --- putSnd p "hi" - --- -- The forked thread's value is not returned, so we go to a little extra work --- -- here to bounce the value through the First of the pair. --- fork $ putFst p =<< getSnd p --- waste_time - --- putSnd p "there" --- getFst p - --- -- | Another multiple put error. This one makes sure that ANY tops get thrown as --- -- exceptions, or we have full nondeterminism (not even limited guarantees), the --- -- program would return "a" or "b". --- case_i6a :: Assertion --- case_i6a = assertException ["Multiple puts to an IVar!"] i6a --- i6a = runParIO ( --- do p <- newPair --- putFst p 3 - --- -- TODO: Randomize these amounts of time: --- fork $ do waste_time --- putSnd p "a" --- fork $ do waste_time --- putSnd p "b" --- -- There's no 'consume' here; so we should really just get a --- -- "Multiple puts to an IVar!" exception. --- getSnd p) - - --- -- TODO: --- -------------------------------- --- -- | This test, semantically, has two possible outcomes. It can return "hi" or an --- -- error. That's quasi-determinism. In practice, we force it to have one outcome by --- -- wasting a significant amount of time in one branch. --- -------------------------------- - - --- waste_time = loop 1000 3.3 --- where --- loop 0 acc = if acc < 10 then return acc else return 0 --- loop i !acc = loop (i - 1) (sin acc + 1.0) - --- -- More pairs --- case_v6 :: Assertion --- case_v6 = assertEqual "fancy pairs" --- 33 =<< runParIO ( --- do p1 <- newPair --- p2 <- newPair --- fork $ do x <- getFst p1 --- putSnd p2 x --- fork $ do x <- getSnd p2 --- putSnd p1 x --- putFst p1 33 --- getSnd p1) - - --------------------------------------------------------------------------------- --- Freeze-related tests: --------------------------------------------------------------------------------- - -case_dftest0 = assertEqual "manual freeze, outer layer" "hello" =<< dftest0 - -dftest0 :: IO String -dftest0 = runParIO $ do - iv1 <- IV.new - iv2 <- IV.new - IV.put_ iv1 iv2 - IV.put_ iv2 "hello" - m <- IV.freezeIVar iv1 - case m of - Just i -> IV.get i - -case_dftest1 = assertEqual "deefreeze double ivar" (Just "hello") =<< dftest1 - --- | Should return (Just (Just "hello")) -dftest1 :: IO (Maybe String) -dftest1 = runParIO $ do - iv1 <- IV.new - iv2 <- IV.new - IV.put_ iv1 iv2 - IV.put_ iv2 "hello" - Just x <- IV.freezeIVar iv1 - IV.freezeIVar x - -case_dftest3 = assertEqual "freeze simple ivar" (Just 3) =<< dftest3 -dftest3 :: IO (Maybe Int) -dftest3 = runParIO $ do - iv1 <- IV.new - IV.put_ iv1 (3::Int) - IV.freezeIVar iv1 - - ---FIXME: - --- -- | Polymorphic version of previous. DeepFrz is more flexible than regular --- -- freeze, because we can pick multiple return types for the same code. But we must --- -- be very careful with this kind of thing due to the 's' type variables. --- dftest4_ :: DeepFrz (IV.IVar s1 Int) => --- Par QuasiDet s1 b --- dftest4_ = do --- iv1 <- newBottom --- IV.put_ iv1 (3::Int) --- res <- IV.freezeIVar iv1 --- return res - --- case_dftest4a = assertEqual "freeze polymorphic 1" (Just 3) =<< dftest4a --- dftest4a :: IO (Maybe Int) --- dftest4a = runParIO dftest4_ - ------------------------------------------------------------------------------------------- --- Show instances ------------------------------------------------------------------------------------------- - -case_show01 :: Assertion -case_show01 = assertEqual "show for IVar" "Just 3" show01 -show01 :: String -show01 = show$ runParThenFreeze $ do v <- IV.new; IV.put v (3::Int); return v - --- | It happens that these come out in the opposite order from the Pure one: -case_show02 :: Assertion -case_show02 = assertEqual "show for SLMap" "{IMap: (\"key2\",44), (\"key1\",33)}" show02 -show02 :: String -show02 = show$ runParThenFreeze $ do - mp <- SM.newEmptyMap - SM.insert "key1" (33::Int) mp - SM.insert "key2" (44::Int) mp - return mp - -case_show03 :: Assertion -case_show03 = assertEqual "show for PureMap" "{IMap: (\"key1\",33), (\"key2\",44)}" show03 -show03 :: String -show03 = show$ runParThenFreeze $ do - mp <- IM.newEmptyMap - IM.insert "key1" (33::Int) mp - IM.insert "key2" (44::Int) mp - return mp - -case_show04 :: Assertion -case_show04 = assertEqual "show for IStructure" "{IStructure: Just 33, Just 44}" show04 -show04 :: String -show04 = show$ runParThenFreeze $ do - ist <- ISt.newIStructure 2 - ISt.put ist 0 (33::Int) - ISt.put ist 1 (44::Int) - return ist - -case_show05 :: Assertion -case_show05 = assertEqual "show for PureSet" "{ISet: 33, 44}" (show show05) -show05 :: ISet Frzn Int -show05 = runParThenFreeze $ do - is <- IS.newEmptySet - IS.insert (33::Int) is - IS.insert (44::Int) is - return is - --- | It happens that these come out in the opposite order from the Pure one: -case_show06 :: Assertion -case_show06 = assertEqual "show for SLSet" "{ISet: 44, 33}" (show show06) -show06 :: SS.ISet Frzn Int -show06 = runParThenFreeze $ do - is <- SS.newEmptySet - SS.insert (33::Int) is - SS.insert (44::Int) is - return is - ----------------------------------------- --- Test sortFrzn instances: - -case_show05B :: Assertion -case_show05B = assertEqual "show for PureSet/Trvrsbl" "AFoldable [33, 44]" (show show05B) -show05B :: G.AFoldable Int -show05B = G.sortFrzn show05 - -case_show06B :: Assertion -case_show06B = assertEqual "show for SLSet/Trvrsbl" "AFoldable [44, 33]" (show show06B) -show06B :: G.AFoldable Int -show06B = G.sortFrzn show06 - ------------------------------------------------------------------------------------------- --- Misc Helpers ------------------------------------------------------------------------------------------- - --- | Ensure that executing an action returns an exception --- containing one of the expected messages. -assertException :: [String] -> IO a -> IO () -assertException msgs action = do - x <- catch (do action; return Nothing) - (\e -> do putStrLn $ "Good. Caught exception: " ++ show (e :: SomeException) - return (Just $ show e)) - case x of - Nothing -> error "Failed to get an exception!" - Just s -> - if any (`isInfixOf` s) msgs - then return () - else error $ "Got the wrong exception, expected one of the strings: "++ show msgs - ++ "\nInstead got this exception:\n " ++ show s - --- | For testing quasi-deterministic programs: programs that always --- either raise a particular exception or produce a particular answer. -allowSomeExceptions :: [String] -> IO a -> IO (Either SomeException a) -allowSomeExceptions msgs action = do - catch (do a <- action; evaluate a; return (Right a)) - (\e -> - let estr = show e in - if any (`isInfixOf` estr) msgs - then do when (dbgLvl>=1) $ - putStrLn $ "Caught allowed exception: " ++ show (e :: SomeException) - return (Left e) - else error $ "Got the wrong exception, expected one of the strings: "++ show msgs - ++ "\nInstead got this exception:\n " ++ show estr) - -exceptionOrTimeOut :: Double -> [String] -> IO a -> IO () -exceptionOrTimeOut time msgs action = do - x <- timeOut time $ - allowSomeExceptions msgs action - case x of - Just (Right _val) -> error "exceptionOrTimeOut: action returned successfully!" - Just (Left _exn) -> return () -- Error, yay! - Nothing -> return () -- Timeout. - --- | Time-out an IO action by running it on a separate thread, which is killed when --- the timer expires. This requires that the action do allocation, otherwise it will --- be non-preemptable. -timeOut :: Double -> IO a -> IO (Maybe a) -timeOut interval act = do - result <- newIORef Nothing - tid <- forkIO (act >>= writeIORef result . Just) - t0 <- getCurrentTime - let loop = do - stat <- threadStatus tid - case stat of - ThreadFinished -> readIORef result - ThreadBlocked _ -> return Nothing - ThreadDied -> return Nothing - ThreadRunning -> do - now <- getCurrentTime - let delt :: Double - delt = fromRational$ toRational$ diffUTCTime now t0 - if delt >= interval - then do killThread tid -- TODO: should probably wait for it to show up as dead. - return Nothing - else do threadDelay (10 * 1000) - loop - loop - -assertOr :: Assertion -> Assertion -> Assertion -assertOr act1 act2 = - catch act1 - (\(e::SomeException) -> act2) - -nTimes :: Int -> (Int -> IO a) -> IO () -nTimes 0 _ = return () -nTimes n c = c n >> nTimes (n-1) c