lvish 1.0.0.6 → 1.1.1.1

raw patch · 47 files changed

+5456/−2029 lines, 47 filesdep +QuickCheckdep +asyncdep +bits-atomicdep ~containersPVP ok

version bump matches the API change (PVP)

Dependencies added: QuickCheck, async, bits-atomic, fgl, graphviz, lvish, missing-foreign, par-classes, par-collections, test-framework-quickcheck2, text

Dependency ranges changed: containers

API changes (from Hackage documentation)

Files

• Control/LVish.hs +69/−197
• Control/LVish/Basics.hs +267/−0
• Control/LVish/BulkRetry.hs +163/−0
• Control/LVish/Internal.hs +13/−5
• Control/LVish/Logging.hs +442/−0
• Control/LVish/Logical.hs +112/−0
• Control/LVish/SchedIdempotent.hs +251/−185
• Control/LVish/SchedIdempotentInternal.hs +88/−22
• Control/LVish/Types.hs +22/−2
• Control/LVish/Unsafe.hs +13/−0
• Data/Concurrent/Bag.hs +3/−2
• Data/Concurrent/Counter.hs +3/−0
• Data/Concurrent/LinkedMap.hs +109/−8
• Data/Concurrent/SkipListMap.hs +179/−11
• Data/LVar/AddRemoveSet.hs +91/−0
• Data/LVar/CycGraph.hs +576/−0
• Data/LVar/Generic.hs +5/−2
• Data/LVar/Generic/Internal.hs +20/−6
• Data/LVar/IStructure.hs +6/−5
• Data/LVar/IVar.hs +31/−24
• Data/LVar/Internal/Pure.hs +110/−9
• Data/LVar/MaxCounter.hs +2/−2
• Data/LVar/Memo.hs +110/−0
• Data/LVar/NatArray.hs +284/−0
• Data/LVar/NatArray/Unsafe.hs +27/−0
• Data/LVar/PNCounter.hs +73/−0
• Data/LVar/PureMap.hs +84/−101
• Data/LVar/PureMap/Unsafe.hs +167/−0
• Data/LVar/PureSet.hs +12/−9
• Data/LVar/SLMap.hs +120/−13
• Data/LVar/SLMap/Unsafe.hs +9/−0
• Data/LVar/SLSet.hs +13/−10
• Data/UtilInternal.hs +11/−6
• TestHelpers.hs +0/−186
• lvish.cabal +103/−24
• tests/ArrayTests.hs +256/−0
• tests/GenericTests.hs +79/−0
• tests/LVishAndIVar.hs +423/−0
• tests/LogicalTests.hs +84/−0
• tests/Main.hs +49/−0
• tests/MaxCounterTests.hs +45/−0
• tests/MemoTests.hs +100/−0
• tests/PureMapTests.hs +98/−0
• tests/SLMapTests.hs +64/−0
• tests/SetTests.hs +287/−0
• tests/TestHelpers.hs +383/−0
• unit-tests.hs +0/−1200

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

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

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

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

@@ -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 _ = "<IO Bool>"+  +instance Show (IO Int) where+  show _ = "<IO Int>"++-- | 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)+	 )

@@ -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+++-- <DUPLICATED CODE>+-- 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 ()+-- </DUPLICATED CODE>++--------------------------------------------------------------------------------+-- 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+

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

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

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

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

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

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

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

@@ -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 _ = "<LinkedMap>"++instance Show (LM.LMList k v) where+  show _ = "<LinkedMapList>"  ++-- | 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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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