diff --git a/Control/Monad/Trans/Region/Concurrent.hs b/Control/Monad/Trans/Region/Concurrent.hs --- a/Control/Monad/Trans/Region/Concurrent.hs +++ b/Control/Monad/Trans/Region/Concurrent.hs @@ -21,7 +21,10 @@ , forkOS #ifdef __GLASGOW_HASKELL__ , forkOnIO +#if MIN_VERSION_base(4,3,0) + , forkIOUnmasked #endif +#endif ) where import Control.Monad.Trans.Region.Internal @@ -29,5 +32,8 @@ , forkOS #ifdef __GLASGOW_HASKELL__ , forkOnIO +#if MIN_VERSION_base(4,3,0) + , forkIOUnmasked +#endif #endif ) diff --git a/Control/Monad/Trans/Region/Internal.hs b/Control/Monad/Trans/Region/Internal.hs --- a/Control/Monad/Trans/Region/Internal.hs +++ b/Control/Monad/Trans/Region/Internal.hs @@ -6,11 +6,15 @@ , KindSignatures -- To help the type-checker. , EmptyDataDecls -- For the RootRegion type. , MultiParamTypeClasses -- For the AncestorRegion class. - , UndecidableInstances -- ) - , FlexibleInstances -- ) For the AncestorRegion instances. - , OverlappingInstances -- ) + , UndecidableInstances -- For the AncestorRegion instances. + , FlexibleInstances -- ,, ,, ,, + , OverlappingInstances -- ,, ,, ,, #-} +#if MIN_VERSION_base(4,3,0) +{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} -- For block and unblock +#endif + ------------------------------------------------------------------------------- -- | -- Module : Control.Monad.Trans.Region.Internal @@ -45,8 +49,10 @@ , forkOS #ifdef __GLASGOW_HASKELL__ , forkOnIO +#if MIN_VERSION_base(4,3,0) + , forkIOUnmasked #endif - +#endif -- * Duplication , Dup(dup) @@ -68,7 +74,7 @@ -- from base: import Prelude ( (+), (-), seq ) import Control.Applicative ( Applicative, Alternative ) -import Control.Monad ( Monad, return, when, forM_ , MonadPlus ) +import Control.Monad ( Monad, return, when, forM_, MonadPlus ) import Control.Monad.Fix ( MonadFix ) import System.IO ( IO ) import Data.Function ( ($) ) @@ -81,14 +87,19 @@ import qualified GHC.Conc ( forkOnIO ) #endif -#if __GLASGOW_HASKELL__ < 701 -import Prelude ( fromInteger ) -import Control.Monad ( (>>=), (>>), fail ) +#if __GLASGOW_HASKELL__ < 700 +import Prelude ( fromInteger ) +import Control.Monad ( (>>=), (>>), fail ) #endif +#if MIN_VERSION_base(4,3,0) +import Control.Exception ( block, unblock ) +#endif + -- from monad-peel: -import Control.Monad.IO.Peel ( MonadPeelIO ) -import Control.Exception.Peel ( bracket ) +import Control.Monad.Trans.Peel ( MonadTransPeel ) +import Control.Monad.IO.Peel ( MonadPeelIO, liftIOOp_ ) +import Control.Exception.Peel ( bracket ) -- from transformers: import Control.Monad.Trans.Class ( MonadTrans, lift ) @@ -103,9 +114,14 @@ -- Handling the new asynchronous exceptions API in base-4.3: #if MIN_VERSION_base(4,3,0) -import Control.Exception ( mask_ ) +import Control.Exception ( mask, mask_ ) #else -import Control.Exception ( block ) +import Control.Exception ( blocked, block, unblock ) +import Data.Function ( id ) + +mask ∷ ((∀ α. IO α → IO α) → IO β) → IO β +mask io = blocked >>= \b → if b then io id else block $ io unblock + mask_ ∷ IO α → IO α mask_ = block #endif @@ -120,9 +136,7 @@ to return an opened resource from the region. The latter ensures no I/O with closed resources is possible. -} -newtype RegionT s (pr ∷ * → *) α = RegionT - { unRegionT ∷ ReaderT (IORef [RefCountedFinalizer]) pr α } - +newtype RegionT s pr α = RegionT (ReaderT (IORef [RefCountedFinalizer]) pr α) deriving ( Functor , Applicative , Alternative @@ -130,16 +144,20 @@ , MonadPlus , MonadFix , MonadTrans + , MonadTransPeel , MonadIO , MonadPeelIO ) +unRegionT ∷ RegionT s pr α → ReaderT (IORef [RefCountedFinalizer]) pr α +unRegionT (RegionT r) = r + -- | A 'Finalizer' paired with its reference count which defines how many times -- it has been registered in some region. data RefCountedFinalizer = RefCountedFinalizer !Finalizer !(IORef RefCnt) -- | An 'IO' computation that closes or finalizes a resource. For example --- @hClose@ or @free@. +-- \"@hClose someHandle@\" or \"@free somePtr@\". type Finalizer = IO () type RefCnt = Int @@ -149,11 +167,12 @@ -- * Registering finalizers -------------------------------------------------------------------------------- --- | A handle to a 'Finalizer' that allows you to duplicate it to a parent --- region using 'dup'. --- --- Duplicating a finalizer means that instead of it being performed when the --- current region terminates it is performed when the parent region terminates. +{-| A handle to a 'Finalizer' that allows you to duplicate it to a parent region +using 'dup'. + +Duplicating a finalizer means that instead of it being performed when the +current region terminates it is performed when the parent region terminates. +-} newtype FinalizerHandle (r ∷ * → *) = FinalizerHandle RefCountedFinalizer {-| Register the 'Finalizer' in the region. When the region terminates all @@ -258,17 +277,29 @@ -- | Like 'forkIO' but internally uses @GHC.Conc.'GHC.Conc.forkOnIO'@. forkOnIO ∷ MonadIO pr ⇒ Int → RegionT s IO () → RegionT s pr ThreadId forkOnIO = fork ∘ GHC.Conc.forkOnIO + +#if MIN_VERSION_base(4,3,0) +-- | Like 'forkIO', but the child thread is created with asynchronous exceptions +-- unmasked (see 'Control.Exception.mask'). +forkIOUnmasked ∷ MonadIO pr ⇒ RegionT s IO () → RegionT s pr ThreadId +forkIOUnmasked r = + RegionT $ ReaderT $ \hsIORef → liftIO $ do + hs ← readIORef hsIORef + block $ do + forM_ hs $ \(RefCountedFinalizer _ refCntIORef) → increment refCntIORef + Control.Concurrent.forkIO $ runRegionWith hs $ liftIOOp_ unblock r #endif +#endif fork ∷ MonadIO pr ⇒ (IO () → IO ThreadId) → (RegionT s IO () → RegionT s pr ThreadId) -fork doFork = \m → +fork doFork = \r → RegionT $ ReaderT $ \hsIORef → liftIO $ do hs ← readIORef hsIORef - mask_ $ do + mask $ \restore → do forM_ hs $ \(RefCountedFinalizer _ refCntIORef) → increment refCntIORef - doFork $ runRegionWith hs m + doFork $ runRegionWith hs $ liftIOOp_ restore r increment ∷ IORef RefCnt → IO () increment ioRef = do refCnt' ← atomicModifyIORef ioRef $ \refCnt → @@ -380,14 +411,14 @@ -------------------------------------------------------------------------------- --- | The @RootRegion@ is the ancestor of any region. --- --- It's primary purpose is to tag regional handles which don't have an --- associated finalizer. For example the standard file handles @stdin@, @stdout@ --- and @stderr@ which are opened on program startup and which shouldn't be --- closed when a region terminates. Another example is the @nullPtr@ which is a --- memory pointer which doesn't point to any allocated memory so doesn't need to --- be freed. +{-| The @RootRegion@ is the ancestor of any region. + +It's primary purpose is to tag regional handles which don't have an associated +finalizer. For example the standard file handles @stdin@, @stdout@ and @stderr@ +which are opened on program startup and which shouldn't be closed when a region +terminates. Another example is the @nullPtr@ which is a memory pointer which +doesn't point to any allocated memory so doesn't need to be freed. +-} data RootRegion α instance InternalAncestorRegion RootRegion (RegionT s m) diff --git a/Control/Monad/Trans/Region/OnExit.hs b/Control/Monad/Trans/Region/OnExit.hs --- a/Control/Monad/Trans/Region/OnExit.hs +++ b/Control/Monad/Trans/Region/OnExit.hs @@ -2,7 +2,7 @@ ------------------------------------------------------------------------------- -- | --- Module : Control.Monad.Trans.Region.Unsafe +-- Module : Control.Monad.Trans.Region.OnExit -- Copyright : (c) 2009-2010 Bas van Dijk -- License : BSD3 (see the file LICENSE) -- Maintainer : Bas van Dijk diff --git a/regions.cabal b/regions.cabal --- a/regions.cabal +++ b/regions.cabal @@ -1,5 +1,5 @@ name: regions -version: 0.8 +version: 0.8.1 cabal-version: >=1.6 build-type: Simple license: BSD3 @@ -24,8 +24,8 @@ . . - Also see the @regions-monadsfd@ and @regions-monadstf@ packages which provide - instances for the classes in the respected monads packages. + Also see the @regions-mtl@ and @regions-monadstf@ packages which provide + instances for the classes in the respected monad transformers packages. . For an example on how to use this library see the @safer-file-handles@, @usb-safe@ or @regional-pointers@ packages.