strict-concurrency (empty) → 0.1

raw patch · 9 files changed

+493/−0 lines, 9 filesdep +basebuild-type:Customsetup-changed

Dependencies added: base

Files

• Control/Concurrent/Chan/Strict.hs +129/−0
• Control/Concurrent/MVar/Strict.hs +151/−0
• LICENSE +30/−0
• Setup.lhs +3/−0
• strict-concurrency.cabal +22/−0
• tests/chan-test.hs +28/−0
• tests/mvar-test.hs +54/−0
• tests/run-tests +44/−0
• tests/thread-ring.hs +32/−0

@@ -0,0 +1,129 @@+{-# LANGUAGE BangPatterns #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Concurrent.Chan.Strict+-- Copyright   :  (c) The University of Glasgow 2001, Don Stewart 2007+-- License     :  BSD-style+-- +-- Maintainer  :  dons@galois.com+-- Stability   :  experimental+-- Portability :  non-portable (concurrency)+--+-- Unbounded, element-strict channels. Elements will be evaluated to+-- WHNF on entering the channel. For some concurrency applications, this+-- is more desirable than passing an unevaluted thunk through the channel+-- (for instance, it guarantees the node willl be evaluated to WHNF in a+-- worker thead).+--+-- Element-strict channes may potentially use more memory than lazy+-- channels+--+-----------------------------------------------------------------------------++module Control.Concurrent.Chan.Strict (+          -- * The 'Chan' type+        Chan,                   -- abstract++          -- * Operations+        newChan,                -- :: IO (Chan a)+        writeChan,              -- :: Chan a -> a -> IO ()+        readChan,               -- :: Chan a -> IO a+        dupChan,                -- :: Chan a -> IO (Chan a)+        unGetChan,              -- :: Chan a -> a -> IO ()+        isEmptyChan,            -- :: Chan a -> IO Bool++          -- * Stream interface+        getChanContents,        -- :: Chan a -> IO [a]+        writeList2Chan,         -- :: Chan a -> [a] -> IO ()+   ) where++import Prelude++import System.IO.Unsafe         ( unsafeInterleaveIO )+import Control.Concurrent.MVar.Strict++-- 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+-- are used to handle consumers trying to read from an empty channel.++-- |'Chan' is an abstract type representing an unbounded FIFO channel.+data Chan a+ = Chan (MVar (Stream a))+        (MVar (Stream a))++type Stream a = MVar (ChItem a)++data ChItem a = ChItem !a (Stream a)++-- @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 = do+   hole  <- newEmptyMVar+   readm <- newMVar hole+   write <- newMVar hole+   return (Chan readm write)++-- To put an element on a channel, a new hole at the write end is created.+-- What was previously the empty @MVar@ at the back of the channel is then+-- filled in with a new stream element holding the entered value and the+-- new hole.++-- |Write a value to a 'Chan'.+writeChan :: Chan a -> a -> IO ()+writeChan (Chan _read write) val = do+  new_hole <- newEmptyMVar+  modifyMVar_ write $ \old_hole -> do+    putMVar old_hole $! ChItem val new_hole+    return new_hole++-- |Read the next value from the 'Chan'.+readChan :: Chan a -> IO a+readChan (Chan readm _write) = do+  modifyMVar readm $ \read_end -> do+    (ChItem val new_read_end) <- readMVar read_end+        -- Use readMVar here, not takeMVar,+        -- else dupChan doesn't work+    return (new_read_end, val)++-- |Duplicate a 'Chan': the duplicate channel begins empty, but data written to+-- 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 (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 (Chan readm _write) val = do+   new_read_end <- newEmptyMVar+   modifyMVar_ readm $ \read_end -> do+     putMVar new_read_end (ChItem val read_end)+     return new_read_end++-- |Returns 'True' if the supplied 'Chan' is empty.+isEmptyChan :: Chan a -> IO Bool+isEmptyChan (Chan readm write) = do+   withMVar readm $ \r -> do+     w <- readMVar write+     let eq = r == w+     eq `seq` return eq++-- Operators for interfacing with functional streams.++-- |Return a lazy list representing the contents of the supplied+-- 'Chan', much like 'System.IO.hGetContents'.+getChanContents :: 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 = mapM_ . writeChan

@@ -0,0 +1,151 @@+{-# LANGUAGE BangPatterns #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Concurrent.MVar.Strict+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+-- +-- Maintainer  :  libraries@haskell.org+-- Stability   :  experimental+-- Portability :  non-portable (concurrency)+--+-- Synchronising, strict variables+--+-- Values placed in an MVar are evaluated to weak-head normal form+-- before being placed in the MVar, preventing a common source of+-- space-leaks involving synchronising variables.+--+-----------------------------------------------------------------------------++module Control.Concurrent.MVar.Strict+        (+          -- * @MVar@s+          MVar          -- abstract+        , newEmptyMVar  -- :: IO (MVar a)+        , newMVar       -- :: a -> IO (MVar a)+        , takeMVar      -- :: MVar a -> IO a+        , putMVar       -- :: MVar a -> a -> IO ()+        , readMVar      -- :: MVar a -> IO a+        , swapMVar      -- :: MVar a -> a -> IO a+        , tryTakeMVar   -- :: MVar a -> IO (Maybe a)+        , tryPutMVar    -- :: MVar a -> a -> IO Bool+        , isEmptyMVar   -- :: MVar a -> IO Bool+        , withMVar      -- :: MVar a -> (a -> IO b) -> IO b+        , modifyMVar_   -- :: MVar a -> (a -> IO a) -> IO ()+        , modifyMVar    -- :: MVar a -> (a -> IO (a,b)) -> IO b+        , addMVarFinalizer -- :: MVar a -> IO () -> IO ()+    ) where++import GHC.Conc ( MVar, newEmptyMVar, takeMVar, +                  tryTakeMVar, isEmptyMVar, addMVarFinalizer+                )+import GHC.Exts+import GHC.IOBase++import Prelude+import Control.Exception as Exception++-- |Put a value into an 'MVar'.  If the 'MVar' is currently full,+-- 'putMVar' will wait until it becomes empty.+--+-- There are two further important properties of 'putMVar':+--+--   * 'putMVar' is single-wakeup.  That is, if there are multiple+--     threads blocked in 'putMVar', and the 'MVar' becomes empty,+--     only one thread will be woken up.  The runtime guarantees that+--     the woken thread completes its 'putMVar' operation.+--+--   * When multiple threads are blocked on an 'MVar', they are+--     woken up in FIFO order.  This is useful for providing+--     fairness properties of abstractions built using 'MVar's.+--+putMVar  :: MVar a -> a -> IO ()+#ifndef __HADDOCK__+putMVar (MVar mvar#) !x = IO $ \ s# -> -- strict!+    case putMVar# mvar# x s# of+        s2# -> (# s2#, () #)+#endif++-- | A non-blocking version of 'putMVar'.  The 'tryPutMVar' function+-- attempts to put the value @a@ into the 'MVar', returning 'True' if+-- it was successful, or 'False' otherwise.+--+tryPutMVar  :: MVar a -> a -> IO Bool+#ifndef __HADDOCK__+tryPutMVar (MVar mvar#) !x = IO $ \ s# -> -- strict!+    case tryPutMVar# mvar# x s# of+        (# s, 0# #) -> (# s, False #)+        (# s, _  #) -> (# s, True #)+#endif++-- |Create an 'MVar' which contains the supplied value.+newMVar :: a -> IO (MVar a)+newMVar value =+    newEmptyMVar        >>= \ mvar ->+    putMVar mvar value  >>+    return mvar++{-|+  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 m = block $ do+    a <- takeMVar m+    putMVar m a+    return a++{-|+  Take a value from an 'MVar', put a new value into the 'MVar' and+  return the value taken. Note that there is a race condition whereby+  another process can put something in the 'MVar' after the take+  happens but before the put does.+-}+swapMVar :: MVar a -> a -> IO a+swapMVar mvar new = block $ do+    old <- takeMVar mvar+    putMVar mvar new+    return old++{-|+  'withMVar' is a safe wrapper for operating on the contents of an+  'MVar'.  This operation is exception-safe: it will replace the+  original contents of the 'MVar' if an exception is raised (see+  "Control.Exception").+-}+{-# 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 m io = block $ do+    a <- takeMVar m+    b <- Exception.catch (unblock (io a))+            (\e -> do putMVar m a; throw e)+    putMVar m a+    return b++{-|+  A safe wrapper for modifying the contents of an 'MVar'.  Like 'withMVar', +  'modifyMVar' will replace the original contents of the 'MVar' if an+  exception is raised during the operation.+-}+{-# INLINE modifyMVar_ #-}+modifyMVar_ :: MVar a -> (a -> IO a) -> IO ()+modifyMVar_ m io = block $ do+    a  <- takeMVar m+    a' <- Exception.catch (unblock (io a))+            (\e -> do putMVar m a; throw e)+    putMVar m a'++{-|+  A slight variation on 'modifyMVar_' that allows a value to be+  returned (@b@) in addition to the modified value of the 'MVar'.+-}+{-# INLINE modifyMVar #-}+modifyMVar :: 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

@@ -0,0 +1,30 @@+Copyright (c) Lennart Kolmodin++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+   notice, this list of conditions and the following disclaimer in the+   documentation and/or other materials provided with the distribution.++3. Neither the name of the author nor the names of his contributors+   may be used to endorse or promote products derived from this software+   without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS+OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain

@@ -0,0 +1,22 @@+Name:           strict-concurrency+Version:        0.1+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,+        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+Homepage:       http://code.haskell.org/~dons/code/strict-concurrency+build-depends:  base+ghc-options:    -Wall -Werror -fglasgow-exts+extensions:     CPP+exposed-modules: Control.Concurrent.MVar.Strict+                 Control.Concurrent.Chan.Strict

@@ -0,0 +1,28 @@+import Control.Concurrent (forkIO)+#if defined(STRICT)+import Control.Concurrent.Chan.Strict+#else+import Control.Concurrent.Chan+#endif+import System.Environment++-- Fork some computation processes, print their results+main = do+    n <- getArgs >>= readIO . head+    f1 <- run fibonacci+    f2 <- run fibonacci2+    mapM_ print . take n $ zip f1 f2++  -- fork a process, return any messages it produces as a list+  where+    run f = do+        c <- newChan+        l <- getChanContents c+        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)++fibonacci2 = 1 : 1 : zipWith (+) fibonacci2 (tail fibonacci2)

@@ -0,0 +1,54 @@++{- The Computer Language Shootout+   http://shootout.alioth.debian.org/+   Written by Tom Pledger, 13 Nov 2006. modified by Don Stewart -}++import Control.Concurrent (forkIO,yield)+#if defined(STRICT)+import Control.Concurrent.MVar.Strict+#else+import Control.Concurrent.MVar+#endif+import Control.Monad+import System++data Colour = Blue | Red | Yellow++complement a b = case (a,b) of+    (Red,Yellow)    -> Blue+    (Red,Blue)      -> Yellow+    (Red,Red)       -> Red+    (Yellow,Blue)   -> Red+    (Yellow,Red)    -> Blue+    (Yellow,Yellow) -> Yellow+    (Blue,Red)      -> Yellow+    (Blue,Yellow)   -> Red+    (Blue,Blue)     -> Blue++colors = [Blue, Red, Yellow]++data MP = MP !Int !(Maybe Colour) ![Int]++main = do n     <- getArgs >>= readIO . head+          waker <- newEmptyMVar+          mpv   <- newMVar $ MP n Nothing []++          let arrive c t = do+                MP q w d <- takeMVar mpv+                case w of+                    _ | q == 0 -> if length d /= 3 then putMVar mpv $ MP 0 w (t:d)+                                                   else print $ t + sum d++                    Nothing    -> do putMVar mpv $ MP q (Just c) d+                                     c' <- takeMVar waker+                                     arrive c' $! t+1++                    Just k     -> do let c' = complement k c+                                     -- this should cause a space leak:+                                     putMVar waker c'+                                     putMVar mpv $ MP (q-1) Nothing d+                                     arrive c' $! t+1++          mapM_ (forkIO . flip arrive 0) colors+          arrive Blue 0+          replicateM_ 3 yield

@@ -0,0 +1,44 @@+#!/bin/sh++M=5000000+N=2000+O=50000000++ghc          -cpp -O -no-recomp -threaded --make mvar-test.hs -o lazy-mvar+ghc -DSTRICT -cpp -O -no-recomp -threaded --make mvar-test.hs -o strict-mvar++ghc          -cpp -O -no-recomp -threaded --make chan-test.hs -o lazy-chan+ghc -DSTRICT -cpp -O -no-recomp -threaded --make chan-test.hs -o strict-chan++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 MVars ************"+ +echo "** Should have a space leak:"+/usr/bin/time ./lazy-mvar   $M +RTS -tstderr -RTS > /dev/null++echo "** Should run in constant space:"+/usr/bin/time ./strict-mvar $M +RTS -tstderr -RTS > /dev/null++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 ************"++echo "** Should be ok **"+/usr/bin/time ./lazy-thread-ring $O +RTS -tstderr -RTS > /dev/null++echo "** Should be no slower, use constant space **"+/usr/bin/time ./strict-thread-ring $O +RTS -tstderr -RTS > /dev/null

@@ -0,0 +1,32 @@+-- The Computer Language Benchmarks Game+-- http://shootout.alioth.debian.org/+-- Contributed by Jed Brown with improvements by Spencer Janssen and Don Stewart++import Control.Monad+import Control.Concurrent (forkIO)+#if defined(STRICT)+import Control.Concurrent.MVar.Strict+#else+import Control.Concurrent.MVar+#endif+import System.Environment++ring = 503++new l i = do+  r <- newEmptyMVar+  forkIO (thread i l r)+  return r++thread :: Int -> MVar Int -> MVar Int -> IO ()+thread i l r = go+  where go = do+          m <- takeMVar l+          when (m == 1) (print i)+          putMVar r (m - 1) -- strict enough+          when (m > 0) go++main = do+  a <- newMVar . read . head =<< getArgs+  z <- foldM new a [2..ring]+  thread 1 z a