rcu (empty) → 0

raw patch · 12 files changed

+899/−0 lines, 12 filesdep +basedep +directorydep +doctestbuild-type:Customsetup-changed

Dependencies added: base, directory, doctest, filepath, hlint, parallel, stm, transformers

Files

CHANGELOG.markdown +3/−0
LICENSE +26/−0
README.markdown +13/−0
Setup.lhs +46/−0
examples/ListInt.hs +49/−0
examples/RPManyListMoveTest.hs +162/−0
rcu.cabal +82/−0
src/Control/Concurrent/RCU.hs +24/−0
src/Control/Concurrent/RCU/Class.hs +19/−0
src/Control/Concurrent/RCU/Internal.hs +374/−0
tests/doctests.hsc +78/−0
tests/hlint.hs +23/−0

+ CHANGELOG.markdown view

@@ -0,0 +1,3 @@+## 0+* Initial version+

+ LICENSE view

@@ -0,0 +1,26 @@+Copyright 2015 Edward Kmett++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.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``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.

+ README.markdown view

@@ -0,0 +1,13 @@+## rcu++[![Build Status](https://secure.travis-ci.org/ekmett/rcu.png?branch=master)](http://travis-ci.org/ekmett/rcu)++This package is an exploration of read-copy-update in Haskell based loosely on the API in [Relativistic Programming in Haskell](http://web.cecs.pdx.edu/~walpole/papers/haskell2015.pdf) by Cooper and Walpole, but converted to using STM in the spirit of Howard and Walpole.++## Contact Information++Contributions and bug reports are welcome!++Please feel free to contact me through github or on the #haskell IRC channel on irc.freenode.net.++-Edward Kmett

+ Setup.lhs view

@@ -0,0 +1,46 @@+#!/usr/bin/runhaskell+\begin{code}+{-# OPTIONS_GHC -Wall #-}+module Main (main) where++import Data.List ( nub )+import Data.Version ( showVersion )+import Distribution.Package ( PackageName(PackageName), PackageId, InstalledPackageId, packageVersion, packageName )+import Distribution.PackageDescription ( PackageDescription(), TestSuite(..) )+import Distribution.Simple ( defaultMainWithHooks, UserHooks(..), simpleUserHooks )+import Distribution.Simple.Utils ( rewriteFile, createDirectoryIfMissingVerbose )+import Distribution.Simple.BuildPaths ( autogenModulesDir )+import Distribution.Simple.Setup ( BuildFlags(buildVerbosity), fromFlag)+import Distribution.Simple.LocalBuildInfo ( withLibLBI, withTestLBI, LocalBuildInfo(), ComponentLocalBuildInfo(componentPackageDeps) )+import Distribution.Verbosity ( Verbosity )+import System.FilePath ( (</>) )++main :: IO ()+main = defaultMainWithHooks simpleUserHooks+  { buildHook = \pkg lbi hooks flags -> do+     generateBuildModule (fromFlag (buildVerbosity flags)) pkg lbi+     buildHook simpleUserHooks pkg lbi hooks flags+  , postHaddock = \args flags pkg lbi ->+     postHaddock simpleUserHooks args flags pkg lbi+  }++generateBuildModule :: Verbosity -> PackageDescription -> LocalBuildInfo -> IO ()+generateBuildModule verbosity pkg lbi = do+  let dir = autogenModulesDir lbi+  createDirectoryIfMissingVerbose verbosity True dir+  withLibLBI pkg lbi $ \_ libcfg -> do+    withTestLBI pkg lbi $ \suite suitecfg -> do+      rewriteFile (dir </> "Build_" ++ testName suite ++ ".hs") $ unlines+        [ "module Build_" ++ testName suite ++ " where"+        , "deps :: [String]"+        , "deps = " ++ (show $ formatdeps (testDeps libcfg suitecfg))+        ]+  where+    formatdeps = map (formatone . snd)+    formatone p = case packageName p of+      PackageName n -> n ++ "-" ++ showVersion (packageVersion p)++testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [(InstalledPackageId, PackageId)]+testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys++\end{code}

+ examples/ListInt.hs view

@@ -0,0 +1,49 @@+import Control.Concurrent.MVar (takeMVar)+import Control.Concurrent.RCU+import Control.Monad (forM, forM_, replicateM)+import Data.List (group, intercalate)+import Prelude hiding (read)++data List s a = Nil | Cons a (SRef s (List s a))++snapshot :: Int -> List s Int -> ReadingRCU s Int+snapshot acc Nil         = return acc+snapshot acc (Cons x rn) = snapshot (x + acc) =<< readSRef rn++reader :: Int -> Int -> SRef s (List s Int) -> ReadingRCU s Int+reader 0 acc _    = return acc+reader n acc head = do+  acc' <- snapshot acc =<< readSRef head+  reader (n - 1) acc' head++deleteMiddle :: SRef s (List s a) -> WritingRCU s ()+deleteMiddle rl = do+  Cons a rn <- readSRef rl+  Cons _ rm <- readSRef rn+  writeSRef rl $ Cons a rm ++testList :: RCU s (SRef s (List s Int))+testList = do+  tail <- newSRef Nil+  c1   <- newSRef $ Cons (- 1) tail+  c2   <- newSRef $ Cons 1     c1+  newSRef $ Cons 1 c2++main :: IO ()+main = do +  outs <- runRCU $ do+    -- initialize list+    head <- testList+    -- spawn 8 readers, each records 100000 snapshots of the list+    rts <- replicateM 8 $ forking $ reading $ reader 100000 0 head+    -- spawn a writer to delete the middle node+    wt  <- forking $ writing $ deleteMiddle head+    +    -- wait for the readers to finish and print snapshots+    outs <- forM rts $ \rt -> do +      v <- joining rt+      return $ show (rcuThreadId rt) ++ ": " ++ show v+    -- wait for the writer to finish+    joining wt+    return outs+  forM_ outs putStrLn

+ examples/RPManyListMoveTest.hs view

@@ -0,0 +1,162 @@+{-# LANGUAGE NamedFieldPuns #-}+import Control.Concurrent.RCU+import Control.Concurrent.MVar (takeMVar)+import Control.Monad (foldM, forM, forM_, replicateM, when)+import Data.List ((\\), foldl1', group, intercalate)+import Debug.Trace (trace)++data RPList s a = Nil+                | Cons a (SRef s (RPList s a))++data ReaderStats = ReaderStats { total   :: !Integer+                               , full    :: !Integer+                               , missing :: !Integer }+                   deriving Show++sappend' s1 s2 = +  s1 `seq` s2 `seq` ReaderStats { total   = total   s1 + total   s2+                                , full    = full    s1 + full    s2+                                , missing = missing s1 + missing s2 }+++snapshot :: Show a => RPList s a -> RPR s [a]+snapshot Nil         = return []+snapshot (Cons x rn) = do +  l    <- readSRef rn+  --writeSRef rn (Cons undefined rn)+  rest <- snapshot l+  return $ x : rest++readSection :: Show a => SRef s (RPList s a) -> RPR s [a]+readSection head = do+  snapshot =<< readSRef head++readThread :: [Char] -> Int -> SRef s (RPList s Char) -> RPE s ReaderStats+readThread ls n head = +  let st = ReaderStats { total = 0, full = 0, missing = 0 }+      ft = ReaderStats { total = 1, full = 1, missing = 0 }+      et = ReaderStats { total = 1, full = 0, missing = 1 }+      trav st _ = do+        xs <- st `seq` reading $ readSection head+        -- use a strict append operation to avoid building up a giant thunk+        return $ st `sappend'` if null $ ls \\ xs then ft else et+      res = foldM trav st [1..n]+  in res `seq` res++testList :: RP s (SRef s (RPList s Char))+testList = do+  tail <- newSRef Nil+  c4   <- newSRef $ Cons 'E' tail+  c3   <- newSRef $ Cons 'D' c4+  c2   <- newSRef $ Cons 'C' c3+  c1   <- newSRef $ Cons 'B' c2+  newSRef $ Cons 'A' c1++compactShow :: (Show a, Eq a) => [a] -> String+compactShow xs = intercalate ", " $ map (\xs -> show (length xs) ++ " x " ++ show (head xs)) $ group xs++-- left half of a zipper+-- n = 0 gets the first element+-- n = 1 gets the second elemnt, followed by the first+-- ...+nNext :: (Monad (m s), RPRead m s) => Int -> SRef s (RPList s a) -> m s [(RPList s a)]+nNext n head = return . snd =<< foldM scroll (head, []) [1..(max n 0)]+  where scroll (r,ns) _ = do+          node <- readSRef r+          return $ case node of (Cons _ r') -> (r', node:ns)+                                _           -> error "nNext tried to go past the end of the list"++moveNodeForward :: Int -> Int -> SRef s (RPList s a) -> RPW s ()+moveNodeForward i n head = do+  when (n <= 0) $ error "nullary move operation not allowed"+  -- get relevant references at earlier position+  (Cons ep rep):_   <- nNext i head+  (Cons x rx)       <- readSRef rep+  esn               <- readSRef rx+  -- get relevant references at later position+  (Cons lp rlp):_   <- nNext n rep+  -- the new node will need a reference to the new predecessor's current successor+  rlp'              <- copySRef rlp+  -- link in a new copy of the node after its new predecessor+  writeSRef rlp $! Cons x rlp'+  -- we're writing against traversal order, so we don't need to synchronize here.+  -- unlink the old copy of the node at its original position+  writeSRef rep $! esn++moveBforward :: SRef s (RPList s a) -> RPW s ()+moveBforward head = do+  (Cons a ra)    <- readSRef head  -- [A,B,C,D,E]+  bn@(Cons b rb) <- readSRef ra+  (Cons c rc)    <- readSRef rb+  (Cons d rd)    <- readSRef rc+  -- duplicate the reference to E+  rd'            <- copySRef rd+  -- link in a new B after D+  writeSRef rd $! Cons b rd'        -- [A,B,C,D,B,E]+  --synchronizeRP -- interaction of write order and traversal order means you don't need this+  -- unlink the old B+  writeSRef ra bn                  -- [A,C,D,B,E]++moveCback :: SRef s (RPList s a) -> RPW s ()+moveCback head = do+  (Cons a rb)    <- readSRef head+  (Cons b rc)    <- readSRef rb+  -- duplicate pointer to B+  rb'            <- copySRef rb+  (Cons c rd)    <- readSRef rc+  de             <- readSRef rd+  -- link in a new C after A+  writeSRef rb $ Cons c rb'+  -- any reader who starts during this grace period +  -- sees either "ABCD" or "ACBCD"+  synchronizeRP+  -- unlink the old C+  writeSRef rc de+  -- any reader who starts during this grace period +  -- sees either "ACBCD" or "ACBD" ++moveCbackNoSync :: SRef s (RPList s a) -> RPW s ()+moveCbackNoSync head = do+  (Cons a rb)    <- readSRef head+  (Cons b rc)    <- readSRef rb+  -- duplicate reference to B+  rb'            <- copySRef rb+  (Cons c rd)    <- readSRef rc+  de             <- readSRef rd+  -- link in a new C after A+  writeSRef rb $! Cons c rb'+  -- any reader who starts after this write is issued+  -- sees either "ABCD" or "ACBCD"+  --synchronizeRP -- this operation is NOT safe to omit, +                  -- because write order and traversal order are the same+  -- unlink the old C+  writeSRef rc de+  -- any reader who starts after this write is issued+  -- sees "ABD", "ACBCD", or "ACBD" ++main :: IO ()+main = do +  let n = 100+  rsts <- replicateM n $ do+    runRP $ do+      -- initialize list+      head <- testList+      -- spawn 8 readers, each records 10000 snapshots of the list+      --rts  <- replicateM 8 $ forking $ replicateM 400000 $ reading $ readSection head+      rts  <- replicateM 29 $ forking $ readThread "ABCDE" 400000 head+      -- spawn a writer to delete the middle node+      --wt   <- forking $ writing $ moveCback head+      --wt   <- forking $ writing $ moveCbackNoSync head+      wt   <- forking $ writing $ moveBforward head+      --wt   <- forking $ writing $ moveNodeForward 1 1 head+      --wt <- forking $ writing $ return ()+      +      -- wait for the readers to finish and print snapshots+      rsts <- forM rts $ \rt -> do +        rst <- joining rt+        rst `seq` return $ rst+      -- wait for the writer to finish+      joining wt+      return $ foldl1' sappend' rsts+  let rst = foldl1' sappend' rsts+  putStrLn $ "n: " ++ show n ++ ", " ++ show rst

+ rcu.cabal view

@@ -0,0 +1,82 @@+name:          rcu+category:      Data+version:       0+license:       BSD3+cabal-version: >= 1.22+license-file:  LICENSE+author:        Edward A. Kmett+maintainer:    Edward A. Kmett <ekmett@gmail.com>+stability:     provisional+homepage:      http://github.com/ekmett/rcu/+bug-reports:   http://github.com/ekmett/rcu/issues+copyright:     Copyright (C) 2015 Edward A. Kmett+build-type:    Custom+tested-with:   GHC == 7.10.1, GHC == 7.10.2+synopsis:      STM-based Read-Copy-Update+description:   STM-based Read-Copy-Update++extra-source-files:+  examples/*.hs+  CHANGELOG.markdown+  README.markdown++source-repository head+  type: git+  location: git://github.com/ekmett/rcu.git++-- You can disable the doctests test suite with -f-test-doctests+flag test-doctests+  default: True+  manual: True++-- You can disable the doctests test suite with -f-test-doctests+flag test-hlint+  default: True+  manual: True++library+  build-depends:+    base >= 4.8 && < 5,+    stm >= 2.4.4 && < 2.5,+    transformers >= 0.4 && < 0.5++  exposed-modules:+    Control.Concurrent.RCU+    Control.Concurrent.RCU.Class+    Control.Concurrent.RCU.Internal++  ghc-options: -Wall -fwarn-tabs++  hs-source-dirs: src+  default-language: Haskell2010++test-suite doctests+  type:           exitcode-stdio-1.0+  main-is:        doctests.hs+  ghc-options:    -Wall -threaded+  hs-source-dirs: tests+  default-language: Haskell2010++  if !flag(test-doctests)+    buildable: False+  else+    build-depends:+      base >= 4.8,+      directory      >= 1.0,+      doctest        >= 0.9.1,+      filepath,+      parallel++test-suite hlint+  type: exitcode-stdio-1.0+  main-is: hlint.hs+  ghc-options: -w -threaded -rtsopts -with-rtsopts=-N+  hs-source-dirs: tests+  default-language: Haskell2010++  if !flag(test-hlint)+    buildable: False+  else+    build-depends:+      base,+      hlint >= 1.7

+ src/Control/Concurrent/RCU.hs view

@@ -0,0 +1,24 @@+{-# LANGUAGE Trustworthy #-}+-----------------------------------------------------------------------------+-- |+-- Copyright   :  (C) 2015 Edward Kmett+-- License     :  BSD-style (see the file LICENSE)+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable+--+-----------------------------------------------------------------------------+module Control.Concurrent.RCU+  ( SRef+  , RCU, runRCU+  , MonadNew(..)+  , MonadReading(..)+  , MonadWriting(..)+  , MonadRCU(..)+  -- * Implementation Details+  , ReadingRCU+  , WritingRCU+  , RCUThread(rcuThreadId)+  ) where++import Control.Concurrent.RCU.Internal

+ src/Control/Concurrent/RCU/Class.hs view

@@ -0,0 +1,19 @@+{-# LANGUAGE Trustworthy #-}+-----------------------------------------------------------------------------+-- |+-- Copyright   :  (C) 2015 Edward Kmett+-- License     :  BSD-style (see the file LICENSE)+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable+--+-----------------------------------------------------------------------------+module Control.Concurrent.RCU.Class+  ( SRef+  , MonadNew(..)+  , MonadReading(..)+  , MonadWriting(..)+  , MonadRCU(..)+  ) where++import Control.Concurrent.RCU.Internal

+ src/Control/Concurrent/RCU/Internal.hs view

@@ -0,0 +1,374 @@+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# OPTIONS_HADDOCK not-home #-}+-----------------------------------------------------------------------------+-- |+-- Copyright   :  (C) 2015 Edward Kmett+-- License     :  BSD-style (see the file LICENSE)+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable+--+-- STM-based RCU with concurrent writers+-----------------------------------------------------------------------------+module Control.Concurrent.RCU.Internal+  ( SRef(..)+  , RCUThread(..)+  , RCU(..)+  , runRCU+  , ReadingRCU(..)+  , WritingRCU(..)+  , MonadNew(..)+  , MonadReading(..)+  , copySRef+  , MonadWriting(..)+  , MonadRCU(..)+  ) where++import Control.Applicative+import Control.Concurrent+import Control.Concurrent.STM+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Trans.Class+import Control.Monad.Trans.Except+import Control.Monad.Trans.Identity+import Control.Monad.Trans.Maybe+import Control.Monad.Trans.Reader+import Data.Coerce+import Data.Int+import Prelude hiding (read, Read)+import qualified Control.Monad.Trans.RWS.Lazy as Lazy+import qualified Control.Monad.Trans.RWS.Strict as Strict+import qualified Control.Monad.Trans.State.Lazy as Lazy+import qualified Control.Monad.Trans.State.Strict as Strict+import qualified Control.Monad.Trans.Writer.Lazy as Lazy+import qualified Control.Monad.Trans.Writer.Strict as Strict++--------------------------------------------------------------------------------+-- * Shared References+--------------------------------------------------------------------------------++-- | Shared references+newtype SRef s a = SRef { unSRef :: TVar a }+  deriving Eq++--------------------------------------------------------------------------------+-- * MonadNew+--------------------------------------------------------------------------------++class Monad m => MonadNew s m | m -> s where+  -- | Build a new shared reference+  newSRef :: a -> m (SRef s a)+  default newSRef :: (m ~ t n, MonadTrans t, MonadNew s n) => a -> m (SRef s a)+  newSRef a = lift (newSRef a)++instance MonadNew s m => MonadNew s (ReaderT e m)+instance (MonadNew s m, Monoid w) => MonadNew s (Strict.WriterT w m)+instance (MonadNew s m, Monoid w) => MonadNew s (Lazy.WriterT w m)+instance MonadNew s' m => MonadNew s' (Strict.StateT s m)+instance MonadNew s' m => MonadNew s' (Lazy.StateT s m)+instance (MonadNew s' m, Monoid w) => MonadNew s' (Strict.RWST r w s m)+instance (MonadNew s' m, Monoid w) => MonadNew s' (Lazy.RWST r w s m)+instance MonadNew s m => MonadNew s (ExceptT e m)+instance MonadNew s m => MonadNew s (MaybeT m)+instance MonadNew s m => MonadNew s (IdentityT m)++--------------------------------------------------------------------------------+-- * MonadReading+--------------------------------------------------------------------------------++-- | This is a read-side critical section+class MonadNew s m => MonadReading s m | m -> s where+  -- | Read a shared reference.+  readSRef :: SRef s a -> m a+  default readSRef :: (m ~ t n, MonadTrans t, MonadReading s n) => SRef s a -> m a+  readSRef r = lift (readSRef r)+  {-# INLINE readSRef #-}++-- | Copy a shared reference.+copySRef :: MonadReading s m => SRef s a -> m (SRef s a)+copySRef r = do+  a <- readSRef r+  newSRef a+{-# INLINE copySRef #-}++instance MonadReading s m => MonadReading s (ReaderT e m)+instance (MonadReading s m, Monoid w) => MonadReading s (Strict.WriterT w m)+instance (MonadReading s m, Monoid w) => MonadReading s (Lazy.WriterT w m)+instance MonadReading s' m => MonadReading s' (Strict.StateT s m)+instance MonadReading s' m => MonadReading s' (Lazy.StateT s m)+instance (MonadReading s' m, Monoid w) => MonadReading s' (Strict.RWST r w s m)+instance (MonadReading s' m, Monoid w) => MonadReading s' (Lazy.RWST r w s m)+instance MonadReading s m => MonadReading s (ExceptT e m)+instance MonadReading s m => MonadReading s (MaybeT m)+instance MonadReading s m => MonadReading s (IdentityT m)++--------------------------------------------------------------------------------+-- * MonadWriting+--------------------------------------------------------------------------------++-- | This is a write-side critical section+class MonadReading s m => MonadWriting s m | m -> s where+  -- | Write to a shared reference.+  writeSRef :: SRef s a -> a -> m ()+  default writeSRef :: (m ~ t n, MonadTrans t, MonadWriting s n) => SRef s a -> a -> m ()+  writeSRef r a = lift (writeSRef r a)++  -- | Synchronize with other writers.+  --+  -- No other writer can straddle this time bound. It will either see writes from before, or writes after, but never +  -- some of both!+  synchronize :: m ()+  default synchronize :: (m ~ t n, MonadTrans t, MonadWriting s n) => m ()+  synchronize = lift synchronize++instance MonadWriting s m => MonadWriting s (ReaderT e m)+instance (MonadWriting s m, Monoid w) => MonadWriting s (Strict.WriterT w m)+instance (MonadWriting s m, Monoid w) => MonadWriting s (Lazy.WriterT w m)+instance MonadWriting s m => MonadWriting s (Strict.StateT s m)+instance MonadWriting s m => MonadWriting s (Lazy.StateT s m)+instance (MonadWriting s m, Monoid w) => MonadWriting s (Strict.RWST r w s m)+instance (MonadWriting s m, Monoid w) => MonadWriting s (Lazy.RWST r w s m)+instance MonadWriting s m => MonadWriting s (IdentityT m)+instance MonadWriting s m => MonadWriting s (ExceptT e m)+instance MonadWriting s m => MonadWriting s (MaybeT m)++--------------------------------------------------------------------------------+-- * MonadRCU+--------------------------------------------------------------------------------++-- | This is the executor service that can fork, join and execute critical sections.+class+  ( MonadReading s (Reading m)+  , MonadWriting s (Writing m)+  , MonadNew s m+  ) => MonadRCU s m | m -> s where++  -- | A read-side critical section+  type Reading m :: * -> *++  -- | A write-side critical section+  type Writing m :: * -> *++  -- | Threads we can fork and join+  type Thread m :: * -> *++  -- | Fork a thread+  forking  :: m a -> m (Thread m a)++  -- | Join a thread+  joining  :: Thread m a -> m a++  -- | Run a read-side critical section+  reading :: Reading m a -> m a++  -- | Run a write-side critical section+  writing :: Writing m a -> m a++instance MonadRCU s m => MonadRCU s (ReaderT e m) where+  type Reading (ReaderT e m) = ReaderT e (Reading m)+  type Writing (ReaderT e m) = ReaderT e (Writing m)+  type Thread (ReaderT e m) = Thread m+  forking (ReaderT f)  = ReaderT $ \a -> forking (f a)+  joining = lift . joining+  reading (ReaderT f) = ReaderT $ \a -> reading (f a)+  writing (ReaderT f) = ReaderT $ \a -> writing (f a)+  {-# INLINE forking #-}+  {-# INLINE joining #-}+  {-# INLINE reading #-}+  {-# INLINE writing #-}++instance MonadRCU s m => MonadRCU s (IdentityT m) where+  type Reading (IdentityT m) = Reading m+  type Writing (IdentityT m) = Writing m+  type Thread (IdentityT m) = Thread m+  forking (IdentityT m) = IdentityT (forking m)+  joining = lift . joining+  reading m = IdentityT (reading m)+  writing m = IdentityT (writing m)+  {-# INLINE forking #-}+  {-# INLINE joining #-}+  {-# INLINE reading #-}+  {-# INLINE writing #-}++instance MonadRCU s m => MonadRCU s (ExceptT e m) where+  type Reading (ExceptT e m) = ExceptT e (Reading m)+  type Writing (ExceptT e m) = ExceptT e (Writing m)+  type Thread (ExceptT e m) = ExceptT e (Thread m)+  forking (ExceptT m) = lift $ ExceptT <$> forking m+  joining (ExceptT m) = ExceptT $ joining m+  reading (ExceptT m) = ExceptT $ reading m+  writing (ExceptT m) = ExceptT $ writing m+  {-# INLINE forking #-}+  {-# INLINE joining #-}+  {-# INLINE reading #-}+  {-# INLINE writing #-}++instance MonadRCU s m => MonadRCU s (MaybeT m) where+  type Reading (MaybeT m) = MaybeT (Reading m)+  type Writing (MaybeT m) = MaybeT (Writing m)+  type Thread (MaybeT m) = MaybeT (Thread m)+  forking (MaybeT m) = lift $ MaybeT <$> forking m+  joining (MaybeT m) = MaybeT $ joining m+  reading (MaybeT m) = MaybeT $ reading m+  writing (MaybeT m) = MaybeT $ writing m+  {-# INLINE forking #-}+  {-# INLINE joining #-}+  {-# INLINE reading #-}+  {-# INLINE writing #-}++instance (MonadRCU s m, Monoid e) => MonadRCU s (Strict.WriterT e m) where+  type Reading (Strict.WriterT e m) = Strict.WriterT e (Reading m)+  type Writing (Strict.WriterT e m) = Strict.WriterT e (Writing m)+  type Thread (Strict.WriterT e m) = Strict.WriterT e (Thread m)+  forking (Strict.WriterT m) = lift $ Strict.WriterT <$> forking m+  joining (Strict.WriterT m) = Strict.WriterT $ joining m+  reading (Strict.WriterT m) = Strict.WriterT $ reading m+  writing (Strict.WriterT m) = Strict.WriterT $ writing m+  {-# INLINE forking #-}+  {-# INLINE joining #-}+  {-# INLINE reading #-}+  {-# INLINE writing #-}++instance (MonadRCU s m, Monoid e) => MonadRCU s (Lazy.WriterT e m) where+  type Reading (Lazy.WriterT e m) = Lazy.WriterT e (Reading m)+  type Writing (Lazy.WriterT e m) = Lazy.WriterT e (Writing m)+  type Thread (Lazy.WriterT e m) = Lazy.WriterT e (Thread m)+  forking (Lazy.WriterT m) = lift $ Lazy.WriterT <$> forking m+  joining (Lazy.WriterT m) = Lazy.WriterT $ joining m+  reading (Lazy.WriterT m) = Lazy.WriterT $ reading m+  writing (Lazy.WriterT m) = Lazy.WriterT $ writing m+  {-# INLINE forking #-}+  {-# INLINE joining #-}+  {-# INLINE reading #-}+  {-# INLINE writing #-}++--------------------------------------------------------------------------------+-- * Read-Side Critical Sections+--------------------------------------------------------------------------------++-- | This is the basic read-side critical section for an RCU computation+newtype ReadingRCU s a = ReadingRCU { runReadingRCU :: IO a } deriving (Functor, Applicative, Monad)++instance MonadNew s (ReadingRCU s) where+  newSRef = r where+    r :: forall a. a -> ReadingRCU s (SRef s a)+    r = coerce (newTVarIO :: a -> IO (TVar a))++instance MonadReading s (ReadingRCU s) where+  readSRef = r where+    r :: forall a. SRef s a -> ReadingRCU s a+    r = coerce (readTVarIO :: TVar a -> IO a)+  {-# INLINE readSRef #-}++--------------------------------------------------------------------------------+-- * Write-Side Critical Sections+--------------------------------------------------------------------------------++-- | This is the basic write-side critical section for an RCU computation+newtype WritingRCU s a = WritingRCU { runWritingRCU :: TVar Int64 -> STM a }+  deriving Functor++instance Applicative (WritingRCU s) where+  pure a = WritingRCU $ \ _ -> pure a+  WritingRCU mf <*> WritingRCU ma = WritingRCU $ \c -> mf c <*> ma c++instance Monad (WritingRCU s) where+  return a = WritingRCU $ \ _ -> pure a+  WritingRCU m >>= f = WritingRCU $ \ c -> do+    a <- m c+    runWritingRCU (f a) c+  fail s = WritingRCU $ \ _ -> fail s++instance Alternative (WritingRCU s) where+  empty = WritingRCU $ \ _ -> empty+  WritingRCU ma <|> WritingRCU mb = WritingRCU $ \c -> ma c <|> mb c++instance MonadPlus (WritingRCU s) where+  mzero = WritingRCU $ \ _ -> mzero+  WritingRCU ma `mplus` WritingRCU mb = WritingRCU $ \c -> ma c `mplus` mb c++instance MonadNew s (WritingRCU s) where+  newSRef a = WritingRCU $ \_ -> SRef <$> newTVar a++instance MonadReading s (WritingRCU s) where+  readSRef (SRef r) = WritingRCU $ \ _ -> readTVar r+  {-# INLINE readSRef #-}++instance MonadWriting s (WritingRCU s) where+  writeSRef (SRef r) a = WritingRCU $ \ _ -> writeTVar r a+  synchronize = WritingRCU $ \ c -> modifyTVar' c (+1)++--------------------------------------------------------------------------------+-- * RCU Context+--------------------------------------------------------------------------------++-- | This is an RCU computation. It can use 'forking' and 'joining' to form+-- new threads, and then you can use 'reading' and 'writing' to run classic+-- read-side and write-side RCU computations. Contention between multiple+-- write-side computations is managed by STM.+newtype RCU s a = RCU { unRCU :: TVar Int64 -> IO a }+  deriving Functor++instance Applicative (RCU s) where+  pure = return+  (<*>) = ap++instance Monad (RCU s) where+  return a = RCU $ \ _ -> return a+  RCU m >>= f = RCU $ \s -> do+    a <- m s+    unRCU (f a) s++instance MonadNew s (RCU s) where+  newSRef a = RCU $ \_ -> SRef <$> newTVarIO a++-- | This is a basic 'RCU' thread. It may be embellished when running in a more+-- exotic context.+data RCUThread s a = RCUThread+  { rcuThreadId :: {-# UNPACK #-} !ThreadId+  , rcuThreadVar :: {-# UNPACK #-} !(MVar a)+  }++instance MonadRCU s (RCU s) where+  type Reading (RCU s) = ReadingRCU s+  type Writing (RCU s) = WritingRCU s+  type Thread (RCU s) = RCUThread s+  forking (RCU m) = RCU $ \ c -> do+    result <- newEmptyMVar+    tid <- forkIO $ do+      x <- m c+      putMVar result x+    return (RCUThread tid result)+  joining (RCUThread _ m) = RCU $ \ _ -> readMVar m+  reading (ReadingRCU m) = RCU $ \ _ -> m+  writing (WritingRCU m) = RCU $ \ c -> atomically $ do+    _ <- readTVar c -- deliberately incur a data dependency!+    m c+  {-# INLINE forking #-}+  {-# INLINE joining #-}+  {-# INLINE reading #-}+  {-# INLINE writing #-}++instance MonadIO (RCU s) where+  liftIO m = RCU $ \ _ -> m+  {-# INLINE liftIO #-}++-- | Run an RCU computation.+runRCU :: (forall s. RCU s a) -> IO a+runRCU m = do+  c <- newTVarIO 0+  unRCU m c+{-# INLINE runRCU #-}+

+ tests/doctests.hsc view

@@ -0,0 +1,78 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ForeignFunctionInterface #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Main (doctests)+-- Copyright   :  (C) 2012-14 Edward Kmett+-- License     :  BSD-style (see the file LICENSE)+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>+-- Stability   :  provisional+-- Portability :  portable+--+-- This module provides doctests for a project based on the actual versions+-- of the packages it was built with. It requires a corresponding Setup.lhs+-- to be added to the project+-----------------------------------------------------------------------------+module Main where++import Build_doctests (deps)+#if __GLASGOW_HASKELL__ < 710+import Control.Applicative+#endif+import Control.Monad+import Data.List+import System.Directory+import System.FilePath+import Test.DocTest++##if defined(mingw32_HOST_OS)+##if defined(i386_HOST_ARCH)+##define USE_CP+import Control.Applicative+import Control.Exception+import Foreign.C.Types+foreign import stdcall "windows.h SetConsoleCP" c_SetConsoleCP :: CUInt -> IO Bool+foreign import stdcall "windows.h GetConsoleCP" c_GetConsoleCP :: IO CUInt+##elif defined(x86_64_HOST_ARCH)+##define USE_CP+import Control.Applicative+import Control.Exception+import Foreign.C.Types+foreign import ccall "windows.h SetConsoleCP" c_SetConsoleCP :: CUInt -> IO Bool+foreign import ccall "windows.h GetConsoleCP" c_GetConsoleCP :: IO CUInt+##endif+##endif++-- | Run in a modified codepage where we can print UTF-8 values on Windows.+withUnicode :: IO a -> IO a+##ifdef USE_CP+withUnicode m = do+  cp <- c_GetConsoleCP+  (c_SetConsoleCP 65001 >> m) `finally` c_SetConsoleCP cp+##else+withUnicode m = m+##endif++main :: IO ()+main = withUnicode $ getSources >>= \sources -> doctest $+    "-isrc"+  : "-idist/build/autogen"+  : "-optP-include"+  : "-optPdist/build/autogen/cabal_macros.h"+  : "-hide-all-packages"+#ifdef TRUSTWORTHY+  : "-DTRUSTWORTHY=1"+#endif+  : map ("-package="++) deps ++ sources++getSources :: IO [FilePath]+getSources = filter (isSuffixOf ".hs") <$> go "src"+  where+    go dir = do+      (dirs, files) <- getFilesAndDirectories dir+      (files ++) . concat <$> mapM go dirs++getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath])+getFilesAndDirectories dir = do+  c <- map (dir </>) . filter (`notElem` ["..", "."]) <$> getDirectoryContents dir+  (,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c

+ tests/hlint.hs view

@@ -0,0 +1,23 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Main (hlint)+-- Copyright   :  (C) 2013-2015 Edward Kmett+-- License     :  BSD-style (see the file LICENSE)+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>+-- Stability   :  provisional+-- Portability :  portable+--+-- This module runs HLint on the lens source tree.+-----------------------------------------------------------------------------+module Main where++import Control.Monad+import Language.Haskell.HLint+import System.Environment+import System.Exit++main :: IO ()+main = do+    args <- getArgs+    hints <- hlint $ ["src", "--cpp-define=HLINT", "--cpp-ansi"] ++ args+    unless (null hints) exitFailure