concurrent-st (empty) → 0.1

raw patch · 5 files changed

+159/−0 lines, 5 filesdep +basedep +ghc-primsetup-changed

Dependencies added: base, ghc-prim

Files

LICENSE +30/−0
README.md +1/−0
Setup.hs +2/−0
concurrent-st.cabal +27/−0
src/Control/Concurrent/ST.hs +99/−0

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright Andrew Martin (c) 2017++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 Andrew Martin 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.

+ README.md view

@@ -0,0 +1,1 @@+# concurrent-st

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ concurrent-st.cabal view

@@ -0,0 +1,27 @@+name: concurrent-st+version: 0.1+synopsis: Concurrent Haskell in ST+description: Concurrent Haskell in ST+homepage: https://github.com/andrewthad/concurrent-st#readme+license: BSD3+license-file: LICENSE+author: Andrew Martin+maintainer: andrew.thaddeus@gmail.com+copyright: 2017 Andrew Martin+category: software+build-type: Simple+extra-source-files: README.md+cabal-version: >=1.10++library+  hs-source-dirs: src+  exposed-modules:+    Control.Concurrent.ST+  build-depends:+      base >= 4.7 && < 5+    , ghc-prim+  default-language: Haskell2010++source-repository head+  type: git+  location: https://github.com/andrewthad/concurrent-st

+ src/Control/Concurrent/ST.hs view

@@ -0,0 +1,99 @@+{-| This module provides a way to use concurrent haskell+    inside of 'ST'. Using these function subverts the+    usual guarentee we have that 'ST' is deterministic.+-}++{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE MagicHash #-}++{-# OPTIONS_GHC -Wall #-}++module Control.Concurrent.ST+  ( -- * Threads+    ThreadId(..)+  , forkST+  , forkST_+    -- * MVar+  , MVar+  , newEmptyMVar+  , newMVar+  , takeMVar+  , putMVar+  , readMVar+  , tryTakeMVar+  , tryPutMVar+  , isEmptyMVar+  , tryReadMVar+  ) where++import GHC.Prim+import GHC.Exts (isTrue#)+import GHC.ST (ST(..))++data ThreadId s = ThreadId ThreadId#++-- | Creates a new thread to run the 'ST' computation passed+--   as the argument. Since using the 'ThreadId' often+--   leads to non-determinism, the function 'forkST_'+--   is typically to be preferred.+forkST :: ST s () -> ST s (ThreadId s)+forkST action = ST $ \s1 -> case forkST# action s1 of+  (# s2, tid #) -> (# s2, ThreadId tid #)++-- | Creates a new thread to run the 'ST' computation and+--   discard the 'ThreadId'.+forkST_ :: ST s () -> ST s ()+forkST_ action = ST $ \s1 -> case forkST# action s1 of+  (# s2, _ #) -> (# s2, () #)++forkST# :: a -> State# s -> (# State# s, ThreadId# #)+forkST# = unsafeCoerce# fork#++data MVar s a = MVar (MVar# s a)++instance Eq (MVar s a) where+  (MVar mvar1#) == (MVar mvar2#) = isTrue# (sameMVar# mvar1# mvar2#)++newEmptyMVar :: ST s (MVar s a)+newEmptyMVar = ST $ \s1 -> case newMVar# s1 of+  (# s2, v #) -> (# s2, MVar v #)++takeMVar :: MVar s a -> ST s a+takeMVar (MVar mvar#) = ST $ \ s# -> takeMVar# mvar# s#++putMVar  :: MVar s a -> a -> ST s ()+putMVar (MVar mvar#) x = ST $ \ s# ->+  case putMVar# mvar# x s# of+    s2# -> (# s2#, () #)++tryTakeMVar :: MVar s a -> ST s (Maybe a)+tryTakeMVar (MVar m) = ST $ \ s ->+    case tryTakeMVar# m s of+        (# s', 0#, _ #) -> (# s', Nothing #) -- MVar is empty+        (# s', _,  a #) -> (# s', Just a  #) -- MVar is full++tryPutMVar :: MVar s a -> a -> ST s Bool+tryPutMVar (MVar mvar#) x = ST $ \ s# ->+    case tryPutMVar# mvar# x s# of+        (# s, 0# #) -> (# s, False #)+        (# s, _  #) -> (# s, True #)++tryReadMVar :: MVar s a -> ST s (Maybe a)+tryReadMVar (MVar m) = ST $ \ s ->+  case tryReadMVar# m s of+    (# s', 0#, _ #) -> (# s', Nothing #) -- MVar is empty+    (# s', _,  a #) -> (# s', Just a  #) -- MVar is full++isEmptyMVar :: MVar s a -> ST s Bool+isEmptyMVar (MVar mv#) = ST $ \ s# ->+  case isEmptyMVar# mv# s# of+    (# s2#, flg #) -> (# s2#, isTrue# (flg /=# 0#) #)++newMVar :: a -> ST s (MVar s a)+newMVar value = do+  mvar <- newEmptyMVar+  putMVar mvar value+  return mvar++readMVar :: MVar s a -> ST s a+readMVar (MVar mvar#) = ST $ \ s# -> readMVar# mvar# s#