packages feed

strict-concurrency 0.1 → 0.2

raw patch · 5 files changed

+58/−44 lines, 5 filesdep +parallel

Dependencies added: parallel

Files

Control/Concurrent/Chan/Strict.hs view
@@ -41,6 +41,7 @@  import System.IO.Unsafe         ( unsafeInterleaveIO ) import Control.Concurrent.MVar.Strict+import Control.Parallel.Strategies  -- A channel is represented by two @MVar@s keeping track of the two ends -- of the channel contents,i.e.,  the read- and write ends. Empty @MVar@s@@ -55,11 +56,16 @@  data ChItem a = ChItem !a (Stream a) +instance NFData (MVar a)++instance NFData a => NFData (ChItem a) where+    rnf (ChItem a s) = rnf a `seq` rnf s+ -- @newChan@ sets up the read and write end of a channel by initialising -- these two @MVar@s with an empty @MVar@.  -- |Build and returns a new instance of 'Chan'.-newChan :: IO (Chan a)+newChan :: NFData a => IO (Chan a) newChan = do    hole  <- newEmptyMVar    readm <- newMVar hole@@ -72,7 +78,7 @@ -- new hole.  -- |Write a value to a 'Chan'.-writeChan :: Chan a -> a -> IO ()+writeChan :: NFData a => Chan a -> a -> IO () writeChan (Chan _read write) val = do   new_hole <- newEmptyMVar   modifyMVar_ write $ \old_hole -> do@@ -80,7 +86,7 @@     return new_hole  -- |Read the next value from the 'Chan'.-readChan :: Chan a -> IO a+readChan :: NFData a => Chan a -> IO a readChan (Chan readm _write) = do   modifyMVar readm $ \read_end -> do     (ChItem val new_read_end) <- readMVar read_end@@ -92,14 +98,14 @@ -- either channel from then on will be available from both.  Hence this creates -- a kind of broadcast channel, where data written by anyone is seen by -- everyone else.-dupChan :: Chan a -> IO (Chan a)+dupChan :: NFData a => Chan a -> IO (Chan a) dupChan (Chan _read write) = do    hole     <- readMVar write    new_read <- newMVar hole    return (Chan new_read write)  -- |Put a data item back onto a channel, where it will be the next item read.-unGetChan :: Chan a -> a -> IO ()+unGetChan :: NFData a => Chan a -> a -> IO () unGetChan (Chan readm _write) val = do    new_read_end <- newEmptyMVar    modifyMVar_ readm $ \read_end -> do@@ -107,7 +113,7 @@      return new_read_end  -- |Returns 'True' if the supplied 'Chan' is empty.-isEmptyChan :: Chan a -> IO Bool+isEmptyChan ::NFData a =>  Chan a -> IO Bool isEmptyChan (Chan readm write) = do    withMVar readm $ \r -> do      w <- readMVar write@@ -118,12 +124,12 @@  -- |Return a lazy list representing the contents of the supplied -- 'Chan', much like 'System.IO.hGetContents'.-getChanContents :: Chan a -> IO [a]+getChanContents ::NFData a =>  Chan a -> IO [a] getChanContents ch = unsafeInterleaveIO $ do     x  <- readChan ch     xs <- getChanContents ch     return (x:xs)  -- |Write an entire list of items to a 'Chan'.-writeList2Chan :: Chan a -> [a] -> IO ()+writeList2Chan ::NFData a =>  Chan a -> [a] -> IO () writeList2Chan = mapM_ . writeChan
Control/Concurrent/MVar/Strict.hs view
@@ -11,7 +11,7 @@ -- -- Synchronising, strict variables ----- Values placed in an MVar are evaluated to weak-head normal form+-- Values placed in an MVar are evaluated to head normal form -- before being placed in the MVar, preventing a common source of -- space-leaks involving synchronising variables. --@@ -44,6 +44,7 @@  import Prelude import Control.Exception as Exception+import Control.Parallel.Strategies  -- |Put a value into an 'MVar'.  If the 'MVar' is currently full, -- 'putMVar' will wait until it becomes empty.@@ -59,9 +60,9 @@ --     woken up in FIFO order.  This is useful for providing --     fairness properties of abstractions built using 'MVar's. ---putMVar  :: MVar a -> a -> IO ()+putMVar  :: NFData a => MVar a -> a -> IO () #ifndef __HADDOCK__-putMVar (MVar mvar#) !x = IO $ \ s# -> -- strict!+putMVar (MVar mvar#) !x = rnf x `seq` IO $ \ s# -> -- strict!     case putMVar# mvar# x s# of         s2# -> (# s2#, () #) #endif@@ -70,7 +71,7 @@ -- attempts to put the value @a@ into the 'MVar', returning 'True' if -- it was successful, or 'False' otherwise. ---tryPutMVar  :: MVar a -> a -> IO Bool+tryPutMVar  :: NFData a => MVar a -> a -> IO Bool #ifndef __HADDOCK__ tryPutMVar (MVar mvar#) !x = IO $ \ s# -> -- strict!     case tryPutMVar# mvar# x s# of@@ -79,7 +80,7 @@ #endif  -- |Create an 'MVar' which contains the supplied value.-newMVar :: a -> IO (MVar a)+newMVar :: NFData a => a -> IO (MVar a) newMVar value =     newEmptyMVar        >>= \ mvar ->     putMVar mvar value  >>@@ -89,7 +90,7 @@   This is a combination of 'takeMVar' and 'putMVar'; ie. it takes the value   from the 'MVar', puts it back, and also returns it. -}-readMVar :: MVar a -> IO a+readMVar :: NFData a => MVar a -> IO a readMVar m = block $ do     a <- takeMVar m     putMVar m a@@ -101,7 +102,7 @@   another process can put something in the 'MVar' after the take   happens but before the put does. -}-swapMVar :: MVar a -> a -> IO a+swapMVar :: NFData a => MVar a -> a -> IO a swapMVar mvar new = block $ do     old <- takeMVar mvar     putMVar mvar new@@ -116,7 +117,7 @@ {-# INLINE withMVar #-} -- inlining has been reported to have dramatic effects; see -- http://www.haskell.org//pipermail/haskell/2006-May/017907.html-withMVar :: MVar a -> (a -> IO b) -> IO b+withMVar :: NFData a => MVar a -> (a -> IO b) -> IO b withMVar m io = block $ do     a <- takeMVar m     b <- Exception.catch (unblock (io a))@@ -130,7 +131,7 @@   exception is raised during the operation. -} {-# INLINE modifyMVar_ #-}-modifyMVar_ :: MVar a -> (a -> IO a) -> IO ()+modifyMVar_ :: NFData a => MVar a -> (a -> IO a) -> IO () modifyMVar_ m io = block $ do     a  <- takeMVar m     a' <- Exception.catch (unblock (io a))@@ -142,10 +143,11 @@   returned (@b@) in addition to the modified value of the 'MVar'. -} {-# INLINE modifyMVar #-}-modifyMVar :: MVar a -> (a -> IO (a,b)) -> IO b+modifyMVar :: NFData a => MVar a -> (a -> IO (a,b)) -> IO b modifyMVar m io = block $ do     a      <- takeMVar m     (a',b) <- Exception.catch (unblock (io a))                 (\e -> do putMVar m a; throw e)     putMVar m a'     return b+
strict-concurrency.cabal view
@@ -1,22 +1,23 @@ Name:           strict-concurrency-Version:        0.1+Version:        0.2 Synopsis:       Strict concurrency abstractions Category:       Control Description:-        This package provides strict versions of some standard Haskell-        concurrency abstractions (MVars,Chans), which provide control-        over where evaluation takes place not offered by the default-        lazy types. This may be useful for deciding when and where -        evaluation occurs, leading to improved time or space use,+        This package provides head normal form strict versions of some+        standard Haskell concurrency abstractions (MVars,Chans), which+        provide control over where evaluation takes place not offered by+        the default lazy types. This may be useful for deciding when and+        where evaluation occurs, leading to improved time or space use,         depending on the circumstances. License:        BSD3 License-File:   LICENSE Author:         Don Stewart <dons@galois.com> Maintainer:     Don Stewart <dons@galois.com>-Copyright:      (c) 2007 Don Stewart+Copyright:      (c) 2007-8 Don Stewart Homepage:       http://code.haskell.org/~dons/code/strict-concurrency-build-depends:  base-ghc-options:    -Wall -Werror -fglasgow-exts-extensions:     CPP+build-depends:  base, parallel+ghc-options:    -Wall -fglasgow-exts+extensions:     CPP, BangPatterns+build-type:     Simple exposed-modules: Control.Concurrent.MVar.Strict                  Control.Concurrent.Chan.Strict
tests/chan-test.hs view
@@ -21,8 +21,13 @@         forkIO (writeList2Chan c f)         return l --- lazily returns values to the main thread to compute, should run twice--- as fast if we compute in the worker thread-fibonacci = 0 : 1 : zipWith (+) fibonacci (tail fibonacci)+--+-- very computationally expensive jobs: -fibonacci2 = 1 : 1 : zipWith (+) fibonacci2 (tail fibonacci2)+fibonacci = map fib [0..]++fibonacci2 = map fib [1..] -- to defeat CSE++fib 0 = 0+fib 1 = 1+fib n = fib (n-1) + fib (n-2)
tests/run-tests view
@@ -1,7 +1,7 @@ #!/bin/sh +N=35 M=5000000-N=2000 O=50000000  ghc          -cpp -O -no-recomp -threaded --make mvar-test.hs -o lazy-mvar@@ -13,6 +13,17 @@ ghc          -cpp -O -no-recomp -threaded --make thread-ring.hs -o lazy-thread-ring ghc -DSTRICT -cpp -O -no-recomp -threaded --make thread-ring.hs -o strict-thread-ring +echo "******* Testing Chans ************"+ +echo "** Should be slow:"+/usr/bin/time ./lazy-chan   $N +RTS -tstderr -RTS > /dev/null++echo "** Should be fast:"+/usr/bin/time ./strict-chan $N +RTS -tstderr -RTS > /dev/null++echo "** Should be twice as fast (on 2 cores)"+/usr/bin/time ./strict-chan $N +RTS -N2 -tstderr -RTS > /dev/null+ echo "******* Testing MVars ************"   echo "** Should have a space leak:"@@ -23,17 +34,6 @@  echo "** Should pass (2 cores)" /usr/bin/time ./strict-mvar $M +RTS -N2 -tstderr -RTS > /dev/null--echo "******* Testing Chans ************"- -echo "** Should be slow:"-/usr/bin/time ./lazy-chan   $N +RTS -tstderr -RTS > /dev/null--echo "** Should be fast:"-/usr/bin/time ./strict-chan $N +RTS -tstderr -RTS > /dev/null--echo "** Should be fast (2 cores)"-/usr/bin/time ./strict-chan $N +RTS -N2 -tstderr -RTS > /dev/null  echo "******* Testing thread-ring benchmark ************"