diff --git a/.gitignore b/.gitignore new file mode 100644 --- /dev/null +++ b/.gitignore @@ -0,0 +1,17 @@ +dist +dist-newstyle +.ghc.environment.* +cabal.project.local + +# Profiler outputs and formatted reports: +*.prof +*.hp +*.aux +*.ps + +.hspec +.hspec-failures + +# Code coverage: +.hpc +*.tix diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,3 @@ +# 0.1.0.0 + +First release. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,202 @@ + + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright [yyyy] [name of copyright owner] + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,9 @@ +Haskell library for flexible RAII-style resource management. + +This package provides a superset of the functionality supported by +[resourcet][1]; in addition to allowing for early early release, +it also provides move semantics: lifetimes are first class values +and hierarchical, and resources can be moved between them after +allocation. + +[1]: https://hackage.haskell.org/package/resourcet diff --git a/lifetimes.cabal b/lifetimes.cabal new file mode 100644 --- /dev/null +++ b/lifetimes.cabal @@ -0,0 +1,80 @@ +cabal-version: 2.2 +name: lifetimes +version: 0.1.0.0 +synopsis: Flexible manual resource management +description: + The lifetimes package provides support for manual resource management, + in a way that is more flexible than what is provided by @resourcet@ or + @bracket@. + . + Like @resourcet@, this package allows releasing acquired resources early. + In addition, it also provides move semantics: resources can be moved to + a different lifetime after they are acquired. Lifetimes are first class + values, which can themselves be acquired as resources, allowing for + heirarchical management as well. +homepage: https://github.com/zenhack/haskell-lifetimes +license: Apache-2.0 + +license-file: LICENSE +author: Ian Denhardt +maintainer: ian@zenhack.net +copyright: 2021 Ian Denhardt +-- category: + -- Codec + -- Concurrency + -- Control + -- Data + -- Database + -- Development + -- Distribution + -- Game + -- Graphics + -- Language + -- Math + -- Network + -- Sound + -- System + -- Testing + -- Text + -- Web + +build-type: Simple +extra-source-files: + CHANGELOG.md + , README.md + , .gitignore + +source-repository head + type: git + branch: main + location: https://github.com/zenhack/haskell-lifetimes + +common shared-opts + default-extensions: + NoImplicitPrelude + , OverloadedStrings + build-depends: + base >=4.12 && <5 + , containers ^>=0.6.2 + , stm ^>=2.5 + , monad-stm ^>=0.1 + , transformers ^>=0.5.6 + , zenhack-prelude ^>=0.1 + default-language: Haskell2010 + +library + import: shared-opts + hs-source-dirs: src + exposed-modules: + Lifetimes + , Lifetimes.Rc + , Lifetimes.Gc +test-suite tests + import: shared-opts + build-depends: + lifetimes + , hspec ^>=2.7.6 + , safe-exceptions ^>=0.1.7 + type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: Main.hs diff --git a/src/Lifetimes.hs b/src/Lifetimes.hs new file mode 100644 --- /dev/null +++ b/src/Lifetimes.hs @@ -0,0 +1,262 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +-- | Module: Lifetimes +-- Description: Flexible resource management using first class lifetimes. +-- +-- This package is centered around a couple types: +-- +-- * 'Acquire' is a monadic context in which resources can be acquired. +-- These can be executed using 'acquire', or for simpler cases 'withAcquire' +-- or 'acquireValue'. +-- * 'Resource' is a handle to a resource. The value for the resource can +-- be read from this, and the 'Resource' can also be used to manipulate +-- the resource's lifetime. +-- * 'Liftime' is the type of first-class liftimes; resources are attached +-- to these and can be moved between them. +module Lifetimes + ( + -- * Lifetimes + Lifetime + , newLifetime + , withLifetime + + -- * Acquiring resources + , Acquire + , mkAcquire + , withAcquire + , acquire + , acquireValue + , currentLifetime + + -- * Using resources + , Resource + , getResource + , mustGetResource + + -- * Releasing resources + , releaseEarly + , detach + + -- * Move semantics + , moveTo + + -- * Errors + , ResourceExpired(..) + ) where + +import Control.Concurrent.STM +import Control.Exception (Exception, bracket, finally) +import Control.Monad.STM.Class +import Control.Monad.Trans.Reader (ReaderT, ask, runReaderT) +import Data.Foldable (fold) +import qualified Data.Map.Strict as M +import Data.Maybe (fromJust) +import Zhp + +-- | Error thrown when an attempt is made to use an expired +-- resource or lifetime. +data ResourceExpired = ResourceExpired + deriving(Show, Read, Ord, Eq) +instance Exception ResourceExpired + +newtype ReleaseKey = ReleaseKey Word64 + deriving(Show, Read, Ord, Eq, Bounded) + +instance Enum ReleaseKey where + toEnum n = ReleaseKey (toEnum n) + fromEnum (ReleaseKey n) = fromEnum n + +newtype Cleanup = Cleanup { runCleanup :: IO () } + +instance Semigroup Cleanup where + -- We want resources to be released in the opposite order from their + -- acquisition, so x <> y releases y and then x. + Cleanup x <> Cleanup y = Cleanup $ y `finally` x + +instance Monoid Cleanup where + mempty = Cleanup $ pure () + +-- | A 'Lifetime' is a represents the scope in which a 'Resource' is valid; +-- resources are attached to a lifetime when they are acquired, and will +-- be released when the lifetime ends. +data Lifetime = Lifetime + { resources :: TVar (Maybe (M.Map ReleaseKey Cleanup)) + , nextReleaseKey :: TVar ReleaseKey + } + +-- | Represents a resource with type @a@, which has a lifetime and an +-- associated cleanup handler. +data Resource a = Resource + { releaseKey :: TVar ReleaseKey + , lifetime :: TVar Lifetime + , valueCell :: TVar (Maybe a) + } + +-- | An 'Acquire' is a monadic action that acquires some number of resources, +-- and registers cleanup handlers to be executed when their lifetime expires. +newtype Acquire a = Acquire (ReaderT Lifetime IO a) + deriving(Functor, Applicative, Monad, MonadIO) + +newReleaseKey :: Lifetime -> STM ReleaseKey +newReleaseKey Lifetime{nextReleaseKey} = do + key <- readTVar nextReleaseKey + writeTVar nextReleaseKey $! succ key + pure key + +addCleanup :: Lifetime -> Cleanup -> STM ReleaseKey +addCleanup lt clean = do + key <- newReleaseKey lt + modifyMaybeTVar (resources lt) $ M.insert key clean + pure key + +acquire1 :: Lifetime -> IO a -> (a -> IO ()) -> IO (a, Resource a) +acquire1 lt get clean = do + bracket + (get >>= newTVarIO . Just) + (\var -> atomically (readTVar var) >>= traverse_ clean) + (\var -> atomically $ do + value <- fromJust <$> readTVar var + key <- addCleanup lt $ Cleanup (clean value) + writeTVar var Nothing + lifetime <- newTVar lt + releaseKey <- newTVar key + valueCell <- newTVar $ Just value + pure + ( value + , Resource + { releaseKey + , lifetime + , valueCell + } + ) + ) + +-- | Get the lifetime for the resources being acquired. +currentLifetime :: Acquire Lifetime +currentLifetime = Acquire ask + +-- | @'mkAcquire' get cleanup@ acquires a resource with @get@, which will +-- be released by calling @cleanup@ when its lifetime ends. +mkAcquire :: IO a -> (a -> IO ()) -> Acquire a +mkAcquire get cleanup = Acquire $ do + lt <- ask + fst <$> liftIO (acquire1 lt get cleanup) + +-- | Acquire a new lifetime, as its own resource. This allows creating +-- sub-groups of resources, which can be later moved as a unit. +newLifetime :: Acquire Lifetime +newLifetime = mkAcquire createLifetime destroyLifetime + +createLifetime :: IO Lifetime +createLifetime = Lifetime + <$> newTVarIO (Just M.empty) + <*> newTVarIO minBound + +modifyMaybeTVar :: TVar (Maybe a) -> (a -> a) -> STM () +modifyMaybeTVar tvar f = do + content <- readTVar tvar + case content of + Just v -> writeTVar tvar $ Just $! f v + Nothing -> throwSTM ResourceExpired + +getResourceMap :: Lifetime -> STM (M.Map ReleaseKey Cleanup) +getResourceMap lt = + readTVar (resources lt) >>= \case + Just m -> pure m + Nothing -> throwSTM ResourceExpired + +destroyLifetime :: Lifetime -> IO () +destroyLifetime lt = + join $ atomically $ do + clean <- fold <$> getResourceMap lt + writeTVar (resources lt) Nothing + pure $ runCleanup clean + +-- | 'withAcquire' acuires a resource, uses it, and then releases it. +-- @'withAcquire' ('mkAcquire' get cleanup)@ is equivalent to +-- @'bracket' get cleanup@. +withAcquire :: Acquire a -> (a -> IO b) -> IO b +withAcquire acq use = withLifetime $ \lt -> do + res <- acquire lt acq + value <- fromJust <$> atomically (getResource res) + use value + +-- | Execute an IO action within the scope of a newly allocated lifetime, +-- which ends when the IO action completes. +withLifetime :: (Lifetime -> IO a) -> IO a +withLifetime = bracket createLifetime destroyLifetime + +-- | Acquire a resource, attaching it to the supplied lifetime. +acquire :: Lifetime -> Acquire a -> IO (Resource a) +acquire lt (Acquire acq) = do + (lt', res) <- acquire1 lt createLifetime destroyLifetime + value' <- runReaderT acq lt' + valueCell <- atomically $ newTVar $ Just value' + pure res { valueCell } + +-- | Like 'acquire', but returns the value, rather than a 'Resource' wrapper. +-- conveinent when you don't need to move the resource or release it before +-- the lifetime expires. +acquireValue :: Lifetime -> Acquire a -> IO a +acquireValue lt acq = do + res <- acquire lt acq + fromJust <$> atomically (getResource res) + +-- | Move a resource to another lifetime. The resource will be detached from +-- its existing lifetime, and so may live past it, but will be released when +-- the new lifetime expires. +moveTo :: MonadSTM m => Resource a -> Lifetime -> m () +moveTo r newLt = liftSTM $ do + oldKey <- readTVar $ releaseKey r + oldLt <- readTVar $ lifetime r + oldMap <- getResourceMap oldLt + case M.lookup oldKey oldMap of + Nothing -> pure () -- already freed. + Just clean -> do + modifyMaybeTVar (resources oldLt) $ M.delete oldKey + newKey <- newReleaseKey newLt + writeTVar (releaseKey r) $! newKey + modifyMaybeTVar (resources newLt) $ M.insert newKey clean + +-- | Release a resource early, before its lifetime would otherwise end. +releaseEarly :: Resource a -> IO () +releaseEarly r = + bracket + (atomically takeValue) + releaseValue + (\_ -> pure ()) + where + takeValue = do + v <- getResource r + writeTVar (valueCell r) Nothing + pure v + releaseValue v = + for_ v $ \_ -> + join $ atomically (detach r) + +-- | Get the value associated with a resource, returning 'Nothing' if the +-- resource's lifetime is expired. +getResource :: MonadSTM m => Resource a -> m (Maybe a) +getResource r = liftSTM $ readTVar (valueCell r) + +-- | Like 'getResource', but throws a 'ResourceExpired' exception instead +-- of returning a 'Maybe'. +mustGetResource :: MonadSTM m => Resource a -> m a +mustGetResource r = liftSTM $ getResource r >>= \case + Nothing -> throwSTM ResourceExpired + Just v -> pure v + +-- | Detach the resource from its lifetime, returning the cleanup handler. +-- NOTE: if the caller does not otherwise arrange to run the cleanup handler, +-- it will *not* be executed. +detach :: MonadSTM m => Resource a -> m (IO ()) +detach r = liftSTM $ do + key <- readTVar $ releaseKey r + lt <- readTVar $ lifetime r + ltMap <- getResourceMap lt + let result = M.lookup key ltMap + for_ result $ \_ -> + modifyMaybeTVar (resources lt) $ M.delete key + pure $ traverse_ runCleanup result diff --git a/src/Lifetimes/Gc.hs b/src/Lifetimes/Gc.hs new file mode 100644 --- /dev/null +++ b/src/Lifetimes/Gc.hs @@ -0,0 +1,144 @@ +-- | Module: Lifetimes.Gc +-- Description: Attach garbage-collector managed finalizers to resources. +-- +-- This module integrates the lifetimes package with GHC's finalizers; this +-- allows you to have the GC run cleanup actions when a resource is garbage +-- collected, rather than managing its lifetime explicitly. +-- +-- You should think twice before using this; much of the point of this package +-- is to manage resources whose lifetime is *semantically significant*, so +-- in many cases you will want more control over when the resource is released +-- than this module provides. It would be inappropriate to use this +-- if: +-- +-- * You need the resource to be cleaned up promptly for semantic reasons +-- (e.g. dropping a network connection). +-- * The resource is scarce (e.g. file descriptors), so it is not safe to +-- wait for the garbage collector to get around it. +-- +-- It is sometimes appropriate however, when time of release is mostly an +-- implementation detail. In particular, this module is fine for use cases +-- where you would want to use a finalizer anyway, and it can be safer: +-- The GHC APIs allow you to attach finalizers to arbitrary values, but +-- doing so is perlious; the compiler and runtime system are free to do +-- many transformations on the code that uses pure values, so it is easy +-- to end up with the finalizer being run sooner than you intended. This +-- module provides a 'Cell' type for finalizable values which is easier +-- to reason about. +{-# LANGUAGE NamedFieldPuns #-} +module Lifetimes.Gc + ( Cell + , readCell + , acquireCell + , moveToGc + , newCell + , addFinalizer + ) where + +import Control.Concurrent.MVar (MVar, mkWeakMVar, newEmptyMVar) +import Control.Concurrent.STM +import Control.Exception (mask) +import Control.Monad.STM.Class +import Lifetimes +import Zhp + +-- | A cell, containing a value with possible finalizers attached. This differs +-- from 'Resource' in that getting the underlying value cannot fail, since +-- cleanup is controlled by the garbage collector. +newtype Cell a + = Cell (TVar (CellData a)) + deriving(Eq) + +----------------------------------------------------------------------- +-- Implementation notes: +-- +-- From the docs for the 'Weak' type: +-- +-- > WARNING: weak pointers to ordinary non-primitive Haskell types +-- > are particularly fragile, because the compiler is free to optimise +-- > away or duplicate the underlying data structure. Therefore +-- > attempting to place a finalizer on an ordinary Haskell type may +-- > well result in the finalizer running earlier than you expected. +-- > +-- > [...] +-- > +-- > Finalizers can be used reliably for types that are created +-- > explicitly and have identity, such as IORef and MVar. [...] +-- +-- So instead, we provide a 'Cell' type, which: +-- +-- * Wraps simple value +-- * Can be created and read inside STM, and +-- * May safely have finalizers, using the 'addFinalizer' function in +-- this module. +-- * Ensures that the finalizers will not be run before any transaction that +-- reads data is complete. +-- +-- Note that it is *not* safe to use the primitives from "Sys.Mem.Weak" to +-- add finalizers. +----------------------------------------------------------------------- + +-- The actual contents of a cell. This is wrapped in a 'TVar' to force accesses +-- to add the a reference the transaction log from which the finalizers are +-- reachable, thus preventing them from running before the completion of any +-- transaction that examines the value. +data CellData a = CellData + { value :: a + -- ^ The value wrapped by the cell. + + , finalizers :: [MVar ()] + -- ^ Experimentally, TVars appear not to be safe for finalizers, so + -- instead we create MVars for the finalizers, and store them in this + -- list so that we maintain a reference to them. + } + deriving(Eq) + +-- | Get the value from a cell. The value will not be collected until after +-- the all transactions which read it complete. +-- +-- Note that this is intentionally not in 'MonadSTM': it is unsafe to use it +-- in 'IO', since the transaction would be finished as soon as it is read. +-- Instead, in 'IO' you should use acquireCell +readCell :: Cell a -> STM a +readCell (Cell state) = value <$> readTVar state + +-- | Create a new cell, initially with no finalizers. +newCell :: MonadSTM m => a -> m (Cell a) +newCell value = liftSTM $ Cell <$> newTVar CellData { value, finalizers = [] } + +-- | Add a new finalizer to the cell. Cells may have many finalizers +-- attached. +addFinalizer :: Cell a -> IO () -> IO () +addFinalizer (Cell stateVar) fin = do + mvar <- newEmptyMVar + _ <- mkWeakMVar mvar fin + atomically $ modifyTVar' stateVar $ \state@CellData{finalizers} -> + state { finalizers = mvar : finalizers } + +-- | Move a resource to the garbage collector, detaching it from its +-- original lifetime. +moveToGc :: Resource a -> IO (Cell a) +moveToGc r = + mask $ \_ -> join $ atomically $ do + value <- mustGetResource r + fin <- detach r + cell <- newCell value + pure $ do + addFinalizer cell fin + pure cell + + +-- | Acquire a reference to the underlying value. This keeps the finalizer +-- from being run before the acquired reference is dropped. +-- +-- If you need to use the value in 'IO', you should use this to get a +-- reference to it. If you only need to use it in 'STM', 'readCell' +-- may be more ergonomic. +acquireCell :: Cell a -> Acquire a +acquireCell (Cell var) = mkAcquire + (atomically $ value <$> readTVar var) + (\_ -> atomically $ do + -- Touch the contents of the cell, to make sure it stays alive. + CellData{} <- readTVar var + pure () + ) diff --git a/src/Lifetimes/Rc.hs b/src/Lifetimes/Rc.hs new file mode 100644 --- /dev/null +++ b/src/Lifetimes/Rc.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE NamedFieldPuns #-} +-- | Module: Lifetimes.Rc +-- Description: Support for working with reference-counted resources. +-- +-- Rather than associating a resource with one lifetime, a reference counted +-- resource associates each *reference* with a lifetime, and is released when +-- all references have expired. +module Lifetimes.Rc + ( Rc + , addRef + , refCounted + ) where + +import Control.Concurrent.STM +import Lifetimes +import Zhp + +-- | A resource which is managed by reference counting. +data Rc a = Rc + { count :: TVar Int + , value :: a + , cleanup :: IO () + } + +-- | Acquire a new reference. +addRef :: Rc a -> Acquire a +addRef rc = + mkAcquire + (atomically $ incRef rc) + (\_ -> join $ atomically $ decRef rc) + +resourceToRc :: Resource a -> STM (Rc a) +resourceToRc res = do + value <- mustGetResource res + cleanup <- detach res + count <- newTVar 1 + pure Rc { count, cleanup, value } + + +-- | Acquire a resource using refcounting. Takes an 'Acquire' for the underlying +-- resource, and returns one that acquires an initial reference to it. Additional +-- references may be created using 'addRef', and the underlying resource will be +-- kept alive until all resources are released. +refCounted :: Acquire a -> Acquire (Rc a) +refCounted acq = do + lt <- currentLifetime + liftIO $ withLifetime $ \tmpLt -> do + res <- acquire tmpLt acq + acquireValue lt $ mkAcquire + (atomically $ resourceToRc res) + (join . atomically . decRef) + + +incRef :: Rc a -> STM a +incRef Rc{count, value} = do + modifyTVar' count succ + pure value + +decRef :: Rc a -> STM (IO ()) +decRef Rc{count, cleanup} = do + modifyTVar' count pred + c <- readTVar count + pure $ case c of + 0 -> cleanup + _ -> pure () diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,126 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-type-defaults #-} +module Main (main) where + +import Control.Exception.Safe (SomeException, throwString, try) +import Data.IORef +import Lifetimes +import qualified Lifetimes.Gc as Gc +import qualified Lifetimes.Rc as Rc +import System.Mem (performGC) +import Test.Hspec +import Zhp + +main :: IO () +main = hspec $ do + describe "withAcquire" $ do + it "Should run the handler on success" $ do + ref <- newIORef 0 + withAcquire (mkAcquire (pure ()) (\() -> writeIORef ref 1)) $ \_ -> pure () + value <- readIORef ref + value `shouldBe` 1 + it "Should run the handler on exceptions" $ do + ref <- newIORef 0 + result <- try $ withAcquire (mkAcquire (pure ()) (\() -> writeIORef ref 1)) $ \() -> + throwString "Error" + case result of + Right () -> error "Should have thrown an exception" + Left (_ :: SomeException) -> do + value <- readIORef ref + value `shouldBe` 1 + it "Should run cleanup handlers in reverse order" $ do + ref <- newIORef [] + withAcquire + (traverse_ (append ref) [1,2,3]) + pure + value <- readIORef ref + value `shouldBe` [3,2,1] + describe "nested lifetimes" $ do + it "Should order resources underneath their lifetimes." $ do + ref <- newIORef [] + withLifetime $ \lt -> do + void $ acquire lt $ append ref 1 + lt' <- acquireValue lt newLifetime + void $ acquire lt $ append ref 2 + -- even though 3 is allocated after 2, it will be freed when + -- lt' is freed. + void $ acquire lt' $ append ref 3 + value <- readIORef ref + value `shouldBe` [2,3,1] + describe "releaseEarly" $ do + it "Should release the resource immediately" $ do + ref <- newIORef [] + withLifetime $ \lt -> do + void $ acquire lt $ append ref 1 + res2 <- acquire lt $ append ref 2 + void $ acquire lt $ append ref 3 + releaseEarly res2 + value <- readIORef ref + value `shouldBe` [2,3,1] + describe "moveTo" $ do + it "Should live longer when moved to a longer-lived lifetime" $ do + ref <- newIORef [] + withLifetime $ \lt -> do + void $ acquire lt $ append ref 1 + lt' <- acquireValue lt newLifetime + void $ acquire lt $ append ref 2 + res3 <- acquire lt' $ append ref 3 + -- If we didn't move this, it would be freed when lt' + -- is freed, but this will make it live until the end of + -- lt instead. + moveTo res3 lt + value <- readIORef ref + value `shouldBe` [3,2,1] + it "Should do nothing if the resource has already been freed" $ do + ref <- newIORef [] + withLifetime $ \lt -> do + res1 <- acquire lt $ append ref 1 + lt' <- acquireValue lt newLifetime + void $ acquire lt $ append ref 2 + void $ acquire lt' $ append ref 3 + releaseEarly res1 + moveTo res1 lt' + value <- readIORef ref + value `shouldBe` [1,2,3] + describe "Lifetimes.Rc" $ do + it "Should release the resources in order if no extra references are acquired" $ do + ref <- newIORef [] + withLifetime $ \lt -> do + void $ acquire lt $ Rc.refCounted $ append ref 1 + void $ acquire lt $ Rc.refCounted $ append ref 2 + value <- readIORef ref + value `shouldBe` [2,1] + it "Should last until its final reference is dropped" $ do + ref <- newIORef [] + withLifetime $ \lt1 -> do + void $ withLifetime $ \lt2 -> do + res <- acquireValue lt2 $ Rc.refCounted $ append ref 1 + acquire lt1 $ Rc.addRef res + value <- readIORef ref + value `shouldBe` [] + value <- readIORef ref + value `shouldBe` [1] + describe "Lifetimes.Gc" $ do + it "Should not release the resource while an acquired reference is active." $ do + ref <- newIORef [] + cell <- Gc.newCell () + Gc.addFinalizer cell (modifyIORef ref (<>[1])) + withAcquire (Gc.acquireCell cell) $ \() -> do + performGC + value <- readIORef ref + value `shouldBe` [] + describe "moveToGC" $ do + it "Should not release a resource when its original lifetime is up." $ do + ref <- newIORef [] + cell <- withLifetime $ \lt -> do + res <- acquire lt $ append ref 1 + Gc.moveToGc res + value <- readIORef ref + value `shouldBe` [] + -- Touch the value to prevent GC: + withAcquire (Gc.acquireCell cell) $ \_ -> pure () + +append :: IORef [Int] -> Int -> Acquire () +append ref n = mkAcquire + (pure ()) + (\() -> modifyIORef ref (<>[n]))