cml (empty) → 0.1

raw patch · 4 files changed

+325/−0 lines, 4 filesdep +basesetup-changed

Dependencies added: base

Files

Control/Concurrent/CML.hs +274/−0
LICENSE +31/−0
Setup.lhs +3/−0
cml.cabal +17/−0

+ Control/Concurrent/CML.hs view

@@ -0,0 +1,274 @@+--------------------------------------------------------------------------------+-- |+-- Module      :  Control.Concurrent.CML+-- Copyright   :  Avik Chaudhuri 2009 (avik@cs.ucsc.edu)+-- License     :  BSD3+-- +-- Maintainer  :  ben.franksen@online.de+-- Stability   :  provisional+-- Portability :  portable+--+-- Events and Channels as in Concurrent ML (extended with communication guards)+--+-- See /A Concurrent ML Library in Concurrent Haskell/ by Avik Chaudhuri+-- (avik\@cs.ucsc.edu). The original code as well as the papers can be+-- found at <http://www.cs.umd.edu/~Eavik/projects/cmllch/>.+--+-- User-visible changes to the original code:+--+-- * 'Event' and 'Channel' are now abstract types+--+-- * renamed 'new' to 'channel'+--+-- * export list, hierarchical module name & similar goodies+--------------------------------------------------------------------------------+module Control.Concurrent.CML (+  -- * Channels+  -- $channels+  Channel,+  channel,+  receive,+  transmit,+  -- * Events+  -- $events+  Event,+  sync,+  choose,+  wrap,+  guard,+  wrapabort,+  spawn+) where++import Control.Concurrent(ThreadId, forkIO)+import Control.Concurrent.MVar(MVar, newEmptyMVar, putMVar, takeMVar)+import Data.Maybe(isJust)+import Control.Monad(foldM)+import Control.Monad.Fix(fix)++--------------------------------------------------------------------------------++type Commit = MVar Bool+type Decision = MVar (Maybe Commit)+type Candidate = MVar (Maybe Decision)+type In a = MVar (Candidate, a -> Bool)+type Out a = MVar (Candidate, a)++-- | Values of type @a@ can be transported over channels of type @Channel a@.+data Channel a = Channel (In a) (Out a) (MVar a)++type Point = MVar ()+type Name = MVar [Point]+type Abort = MVar ([Point], IO ())+type Synchronizer = MVar (Point, Decision)++-- | Events return a value on synchronization.+--+-- Note that by construction, an event can synchronize at exactly one+-- /commit point/, where a message is either sent or accepted on a+-- channel. This commit point may be selected among several other,+-- potential commit points. Some code may be run before+-- synchronization, as specified by 'guard' functions throughout the+-- event. Some more code may be run after synchronization, as specified+-- by 'wrap' functions that surround the commit point, and by 'wrapabort'+-- functions that do not surround the commit point.+newtype Event a = Event (Synchronizer -> Abort -> Name -> IO a)++--------------------------------------------------------------------------------++atchan :: In a -> Out a -> IO ()+atchan i o = do {+  (ei,patt) <- takeMVar i;+  (eo,y) <- takeMVar o;+  if (patt y) then do {+    si <- newEmptyMVar;+    putMVar ei (Just si);+    ki <- takeMVar si;+    so <- newEmptyMVar;+    putMVar eo (Just so);+    ko <- takeMVar so;+    maybe (return ()) (\ci -> putMVar ci (isJust ko)) ki;+    maybe (return ()) (\co -> putMVar co (isJust ki)) ko+  }+  else do {+    putMVar ei Nothing;+    putMVar ei Nothing;+    atchan i o+  }+}++atsync :: Synchronizer -> Abort -> IO () -> IO ()+atsync r a x = do {+  (t,s) <- takeMVar r;+  forkIO $ fix $ \z -> do {+    (t',s') <- takeMVar r;+    forkIO z;+    putMVar s' Nothing+  };+  c <- newEmptyMVar;+  putMVar s (Just c);+  b <- takeMVar c;+  if b then do {+    putMVar t ();+    fix $ \z -> do {+      (tL,f) <- takeMVar a;+      forkIO z;+      if elem t tL then return ()+      else f+    }+  }+  else x+}++atpointI :: Synchronizer -> Point -> In a -> (a -> Bool) -> IO a -> IO a+atpointI r t i patt x = do {+  e <- newEmptyMVar;+  putMVar i (e,patt);+  ms <- takeMVar e;+  maybe (atpointI r t i patt x) (\s -> do {+      putMVar r (t,s);+      takeMVar t;+      x+    }+  ) ms+}++atpointO :: Synchronizer -> Point -> Out a -> a -> IO () -> IO ()+atpointO r t o y x = do {+  e <- newEmptyMVar;+  putMVar o (e,y);+  ms <- takeMVar e;+  maybe (atpointO r t o y x) (\s -> do {+      putMVar r (t,s);+      takeMVar t;+      x+    }+  ) ms+}++--------------------------------------------------------------------------------++-- $channels+-- Channels transport a single value at a time. The operations on channels are:+-- creation, transmit, and receive. None of them block the calling thread, in+-- fact transmit and receive are pure functions, not IO actions. Blocking may+-- occur only when a thread explicitly synchronizes on the resulting event.++-- | Create a new channel.+channel :: IO (Channel a)+channel = do+  i <- newEmptyMVar+  o <- newEmptyMVar+  forkIO $ fix $ \z -> do+    atchan i o+    z+  m <- newEmptyMVar+  return (Channel i o m)++-- | Receive a message from a channel.+--+-- More precisely, @receive c cond@ returns an event that, on synchronization,+-- accepts a message @m@ on channel @c@ and returns @m@. The resulting+-- event is eligible for synchronization with a @transmit c m@ only if @cond m@+-- is true.+receive :: Channel a -> (a -> Bool) -> Event a+receive (Channel i o m) patt = Event efun where+  efun r a n = do+    t <- newEmptyMVar+    forkIO (putMVar n [t])+    atpointI r t i patt (takeMVar m)++-- | Transmit a message over a channel.+--+-- More precisely, @transmit c m@ returns an event that, on synchronization,+-- sends the message @m@ on channel @c@ and returns @()@. Such an event must+-- synchronize with @receive c@.+transmit :: Channel a -> a -> Event ()+transmit (Channel i o m) y = Event efun where+  efun r a n = do+    t <- newEmptyMVar+    forkIO (putMVar n [t])+    atpointO r t o y (putMVar m y)++-- $events+-- Events encapsulate a potentially blocking point of synchronization between+-- threads, together with possible pre- and post-synchronization code as well+-- as code that is executed (in a separate thread) when an event is /not/+-- selected (aborted).++-- | Non-deterministically select an event from a list of events, so that+-- the selected event can be synchronized. The other events in the list are+-- /aborted/.+choose :: [Event a] -> Event a+choose vL = Event efun where+  efun r a n = do+    j <- newEmptyMVar+    tL <- foldM (\tL -> \(Event v) -> do+        n' <- newEmptyMVar+        forkIO $ do+          x <- v r a n'+          putMVar j x+        tL' <- takeMVar n'+        putMVar n' tL'+        return (tL' ++ tL)+      ) [] vL+    forkIO (putMVar n tL)+    takeMVar j++-- | Specify a post-synchronization action.+--+-- More precisely, @wrap v f@ returns an event that, on synchronization,+-- synchronizes the event @v@ and then runs the action returned by @f@+-- applied to the result.+wrap :: Event a -> (a -> IO b) -> Event b+wrap (Event v) f = Event efun where+  efun r a n = do+    x <- v r a n+    f x++-- | Specify a pre-synchronization action.+--+-- More precisely, @guard a@ returns an event that, on synchronization,+-- synchronizes the event returned by the action @a@. Here, @a@ is run+-- every time a thread /tries/ to synchronize @guard a@.+guard :: IO (Event a) -> Event a+guard vs = Event efun where+  efun r a n = do+    Event v <- vs+    v r a n++-- | Specify a post-synchronization action that is spawned if an event is+-- /not/ selected by a 'choose'.+--+-- More precisely, @wrapabort a v@ returns an event that, on+-- synchronization, synchronizes the event @v@, and on abortion, spawns a+-- thread that runs the action @a@. Here, if @v@ itself is of the form+-- @choose vs@ and one of the events in @vs@ is selected, then @v@ is+-- considered selected, so @a@ is not spawned.+wrapabort :: IO () -> Event a -> Event a+wrapabort f (Event v) = Event efun where+  efun r a n = do+    forkIO $ do+      tL <- takeMVar n+      putMVar n tL+      putMVar a (tL, f)+    v r a n++-- | Synchronize an event.+--+-- This blocks the calling thread until a matching event is available.+sync :: Event a -> IO a+sync (Event v) = do+  j <- newEmptyMVar+  forkIO $ fix $ \z -> do+    r <- newEmptyMVar+    a <- newEmptyMVar+    n <- newEmptyMVar+    forkIO $ atsync r a z+    x <- v r a n+    putMVar j x+  takeMVar j++-- | A synonym for 'forkIO'.+spawn :: IO () -> IO ThreadId+spawn = forkIO

+ LICENSE view

@@ -0,0 +1,31 @@+Copyright Avik Chaudhuri 2009++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * 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.++    * Neither the name of Ben Franksen nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND 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 COPYRIGHT+OWNER 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.+

+ Setup.lhs view

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

+ cml.cabal view

@@ -0,0 +1,17 @@+name:               cml+version:            0.1+synopsis:           Events and Channels as in Concurrent ML+description:+    Implementation of Events and Channels as in CML+    (extended with communication guards).+    See /A Concurrent ML Library in Concurrent Haskell/ by Avik Chaudhuri+    (avik\@cs.ucsc.edu) for details. The original code as well as the papers can+    be found at <http://www.cs.umd.edu/~Eavik/projects/cmllch/>.+category:           Concurrency+license:            BSD3+license-file:       LICENSE+author:             Avik Chaudhuri+maintainer:         ben.franksen@online.de+build-depends:      base+build-type:         Simple+exposed-modules:    Control.Concurrent.CML