rcu 0.1 → 0.2
raw patch · 18 files changed
+1429/−347 lines, 18 filesdep +containersdep +criteriondep +deepseqdep −directorydep −filepathdep ~atomic-primopsdep ~basedep ~doctestsetup-changednew-component:exe:MoveStringGCnew-uploader
Dependencies added: containers, criterion, deepseq, ghc-prim, optparse-applicative, rdtsc, time
Dependencies removed: directory, filepath
Dependency ranges changed: atomic-primops, base, doctest, primitive, transformers
Files
- CHANGELOG.markdown +5/−0
- README.markdown +1/−1
- Setup.lhs +165/−29
- cbits/pause.c +6/−0
- cbits/pause.h +1/−0
- cbits/pause_impl.h +16/−0
- examples/IncCounterExperiment.hs +82/−0
- examples/MoveString.hs +75/−0
- examples/MoveStringQSBR.hs +0/−73
- examples/MoveStringSTM.hs +0/−73
- examples/TimeSynchronize.hs +206/−0
- rcu.cabal +378/−21
- src/Control/Concurrent/RCU/Class.hs +1/−1
- src/Control/Concurrent/RCU/GC.hs +27/−0
- src/Control/Concurrent/RCU/GC/Internal.hs +334/−0
- src/Control/Concurrent/RCU/QSBR/Internal.hs +107/−71
- tests/doctests.hs +25/−0
- tests/doctests.hsc +0/−78
CHANGELOG.markdown view
@@ -1,3 +1,8 @@+## 0.2+* Revamp `Setup.hs` to use `cabal-doctest`. This makes it build+ with `Cabal-2.0`, and makes the `doctest`s work with `cabal new-build` and+ sandboxes.+ ## 0 * Initial version
README.markdown view
@@ -1,6 +1,6 @@ ## rcu -[](http://travis-ci.org/ekmett/rcu)+[](https://hackage.haskell.org/package/rcu) [](http://travis-ci.org/ekmett/rcu) This package is an exploration of Read-Copy Update in Haskell based on [Relativistic Programming in Haskell](http://web.cecs.pdx.edu/~walpole/papers/haskell2015.pdf) by Cooper and Walpole. It includes a sound QSBR-based implementation and an attempt at an STM-based implementation.
Setup.lhs view
@@ -1,46 +1,182 @@-#!/usr/bin/runhaskell \begin{code}-{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-} module Main (main) where +#ifndef MIN_VERSION_cabal_doctest+#define MIN_VERSION_cabal_doctest(x,y,z) 0+#endif+++#if MIN_VERSION_cabal_doctest(1,0,0)+import Distribution.Extra.Doctest ( defaultMainWithDoctests )+#else++-- Otherwise we provide a shim++#ifndef MIN_VERSION_Cabal+#define MIN_VERSION_Cabal(x,y,z) 0+#endif+#ifndef MIN_VERSION_directory+#define MIN_VERSION_directory(x,y,z) 0+#endif+#if MIN_VERSION_Cabal(1,24,0)+#define InstalledPackageId UnitId+#endif++import Control.Monad ( when ) import Data.List ( nub )-import Data.Version ( showVersion )-import Distribution.Package ( PackageName(PackageName), PackageId, InstalledPackageId, packageVersion, packageName )-import Distribution.PackageDescription ( PackageDescription(), TestSuite(..) )+import Data.String ( fromString )+import Distribution.Package ( InstalledPackageId )+import Distribution.Package ( PackageId, Package (..), packageVersion )+import Distribution.PackageDescription ( PackageDescription(), TestSuite(..) , Library (..), BuildInfo (..)) 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 Distribution.Simple.Setup ( BuildFlags(buildDistPref, buildVerbosity), fromFlag)+import Distribution.Simple.LocalBuildInfo ( withPackageDB, withLibLBI, withTestLBI, LocalBuildInfo(), ComponentLocalBuildInfo(componentPackageDeps), compiler )+import Distribution.Simple.Compiler ( showCompilerId , PackageDB (..))+import Distribution.Text ( display , simpleParse ) 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- }+#if MIN_VERSION_Cabal(1,25,0)+import Distribution.Simple.BuildPaths ( autogenComponentModulesDir )+#endif -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))+#if MIN_VERSION_directory(1,2,2)+import System.Directory (makeAbsolute)+#else+import System.Directory (getCurrentDirectory)+import System.FilePath (isAbsolute)++makeAbsolute :: FilePath -> IO FilePath+makeAbsolute p | isAbsolute p = return p+ | otherwise = do+ cwd <- getCurrentDirectory+ return $ cwd </> p+#endif++generateBuildModule :: String -> BuildFlags -> PackageDescription -> LocalBuildInfo -> IO ()+generateBuildModule testsuiteName flags pkg lbi = do+ let verbosity = fromFlag (buildVerbosity flags)+ let distPref = fromFlag (buildDistPref flags)++ -- Package DBs+ let dbStack = withPackageDB lbi ++ [ SpecificPackageDB $ distPref </> "package.conf.inplace" ]+ let dbFlags = "-hide-all-packages" : packageDbArgs dbStack++ withLibLBI pkg lbi $ \lib libcfg -> do+ let libBI = libBuildInfo lib++ -- modules+ let modules = exposedModules lib ++ otherModules libBI+ -- it seems that doctest is happy to take in module names, not actual files!+ let module_sources = modules++ -- We need the directory with library's cabal_macros.h!+#if MIN_VERSION_Cabal(1,25,0)+ let libAutogenDir = autogenComponentModulesDir lbi libcfg+#else+ let libAutogenDir = autogenModulesDir lbi+#endif++ -- Lib sources and includes+ iArgs <- mapM (fmap ("-i"++) . makeAbsolute) $ libAutogenDir : hsSourceDirs libBI+ includeArgs <- mapM (fmap ("-I"++) . makeAbsolute) $ includeDirs libBI++ -- CPP includes, i.e. include cabal_macros.h+ let cppFlags = map ("-optP"++) $+ [ "-include", libAutogenDir ++ "/cabal_macros.h" ]+ ++ cppOptions libBI++ withTestLBI pkg lbi $ \suite suitecfg -> when (testName suite == fromString testsuiteName) $ do++ -- get and create autogen dir+#if MIN_VERSION_Cabal(1,25,0)+ let testAutogenDir = autogenComponentModulesDir lbi suitecfg+#else+ let testAutogenDir = autogenModulesDir lbi+#endif+ createDirectoryIfMissingVerbose verbosity True testAutogenDir++ -- write autogen'd file+ rewriteFile (testAutogenDir </> "Build_doctests.hs") $ unlines+ [ "module Build_doctests where"+ , ""+ -- -package-id etc. flags+ , "pkgs :: [String]"+ , "pkgs = " ++ (show $ formatDeps $ testDeps libcfg suitecfg)+ , ""+ , "flags :: [String]"+ , "flags = " ++ show (iArgs ++ includeArgs ++ dbFlags ++ cppFlags)+ , ""+ , "module_sources :: [String]"+ , "module_sources = " ++ show (map display module_sources) ] where- formatdeps = map (formatone . snd)- formatone p = case packageName p of- PackageName n -> n ++ "-" ++ showVersion (packageVersion p)+ -- we do this check in Setup, as then doctests don't need to depend on Cabal+ isOldCompiler = maybe False id $ do+ a <- simpleParse $ showCompilerId $ compiler lbi+ b <- simpleParse "7.5"+ return $ packageVersion (a :: PackageId) < b + formatDeps = map formatOne+ formatOne (installedPkgId, pkgId)+ -- The problem is how different cabal executables handle package databases+ -- when doctests depend on the library+ | packageId pkg == pkgId = "-package=" ++ display pkgId+ | otherwise = "-package-id=" ++ display installedPkgId++ -- From Distribution.Simple.Program.GHC+ packageDbArgs :: [PackageDB] -> [String]+ packageDbArgs | isOldCompiler = packageDbArgsConf+ | otherwise = packageDbArgsDb++ -- GHC <7.6 uses '-package-conf' instead of '-package-db'.+ packageDbArgsConf :: [PackageDB] -> [String]+ packageDbArgsConf dbstack = case dbstack of+ (GlobalPackageDB:UserPackageDB:dbs) -> concatMap specific dbs+ (GlobalPackageDB:dbs) -> ("-no-user-package-conf")+ : concatMap specific dbs+ _ -> ierror+ where+ specific (SpecificPackageDB db) = [ "-package-conf=" ++ db ]+ specific _ = ierror+ ierror = error $ "internal error: unexpected package db stack: "+ ++ show dbstack++ -- GHC >= 7.6 uses the '-package-db' flag. See+ -- https://ghc.haskell.org/trac/ghc/ticket/5977.+ packageDbArgsDb :: [PackageDB] -> [String]+ -- special cases to make arguments prettier in common scenarios+ packageDbArgsDb dbstack = case dbstack of+ (GlobalPackageDB:UserPackageDB:dbs)+ | all isSpecific dbs -> concatMap single dbs+ (GlobalPackageDB:dbs)+ | all isSpecific dbs -> "-no-user-package-db"+ : concatMap single dbs+ dbs -> "-clear-package-db"+ : concatMap single dbs+ where+ single (SpecificPackageDB db) = [ "-package-db=" ++ db ]+ single GlobalPackageDB = [ "-global-package-db" ]+ single UserPackageDB = [ "-user-package-db" ]+ isSpecific (SpecificPackageDB _) = True+ isSpecific _ = False+ testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [(InstalledPackageId, PackageId)] testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys++defaultMainWithDoctests :: String -> IO ()+defaultMainWithDoctests testSuiteName = defaultMainWithHooks simpleUserHooks+ { buildHook = \pkg lbi hooks flags -> do+ generateBuildModule testSuiteName flags pkg lbi+ buildHook simpleUserHooks pkg lbi hooks flags+ }++#endif++main :: IO ()+main = defaultMainWithDoctests "doctests" \end{code}
+ cbits/pause.c view
@@ -0,0 +1,6 @@+#include "pause_impl.h"++void pause(void)+{+ _pause();+}
+ cbits/pause.h view
@@ -0,0 +1,1 @@+void pause(void);
+ cbits/pause_impl.h view
@@ -0,0 +1,16 @@+// adapted from ghc/includes/stg/SMP.h++static __inline__ void _pause(void)+{+#if defined(i386_HOST_ARCH) || defined(x86_64_HOST_ARCH)+ // On Intel, the busy-wait-nop instruction is called "pause",+ // which is actually represented as a nop with the rep prefix.+ // On processors before the P4 this behaves as a nop; on P4 and+ // later it might do something clever like yield to another+ // hyperthread. In any case, Intel recommends putting one+ // of these in a spin lock loop.+ __asm__ __volatile__ ("rep; nop");+#else+ // nothing+#endif+}
+ examples/IncCounterExperiment.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}+-----------------------------------------------------------------------------+-- |+-- Copyright : (C) 2015 Edward Kmett and Ted Cooper+-- License : BSD-style (see the file LICENSE)+-- Maintainer : Edward Kmett <ekmett@gmail.com>, +-- Ted Cooper <anthezium@gmail.com>+-- Stability : experimental+-- Portability : non-portable+--+-- Which counter increment is faster?+-----------------------------------------------------------------------------++import Control.Monad (forM_)+import Control.Monad.Primitive (primitive)+import Criterion.Main (bench, bgroup, defaultMain, nfIO)+import Data.Word (Word64)+import Data.Primitive+import GHC.Prim --(MutableByteArray, plusWord, readWord64Array, writeWord64Array)+import GHC.Word (Word64 (W64#))++-- | Counter for causal ordering.+newtype Counter = Counter (MutableByteArray RealWorld)++instance Eq Counter where+ Counter m == Counter n = sameMutableByteArray m n++offline :: Word64+offline = 0++online :: Word64+online = 1++-- counterInc :: Word64+-- counterInc = 2 -- online threads will never overflow to 0++newCounter :: IO Counter+newCounter = do+ b <- newByteArray 8+ writeByteArray b 0 online+ return (Counter b)+{-# INLINE newCounter #-}++readCounter :: Counter -> IO Word64+readCounter (Counter c) = readByteArray c 0+{-# INLINE readCounter #-}++writeCounter :: Counter -> Word64 -> IO ()+writeCounter (Counter c) w = writeByteArray c 0 w+{-# INLINE writeCounter #-}++incCounterAtomic :: Counter -> IO Word64+incCounterAtomic (Counter (MutableByteArray c)) = primitive $ \ s -> + case fetchAddIntArray# c 0# 2# s of+ (# s', r #) -> (# s', W64# (int2Word# r) #)+{-# INLINE incCounterAtomic #-}++incCounterNonAtomicFancy :: Counter -> IO Word64+incCounterNonAtomicFancy (Counter (MutableByteArray c)) = primitive $ \ s -> + case readWord64Array# c 0# s of+ (# s', r #) -> case plusWord# r (int2Word# 2#) of+ r' -> case writeWord64Array# c 0# r' s' of+ s'' -> (# s'', W64# r' #)+{-# INLINE incCounterNonAtomicFancy #-}++incCounterNonAtomic :: Counter -> IO Word64+incCounterNonAtomic c = do+ x <- (+ 2) <$> readCounter c+ writeCounter c x+ return x+{-# INLINE incCounterNonAtomic #-}++main :: IO ()+main = defaultMain [ bgroup "incCounterAtomic" $ bunches incCounterAtomic+ , bgroup "incCounterNonAtomicFancy" $ bunches incCounterNonAtomicFancy + , bgroup "incCounterNonAtomic" $ bunches incCounterNonAtomic ]+ where bunches m = [ bench (show n) + $ nfIO $ do c <- newCounter+ forM_ [1..n] $ \ _ -> m c+ | n <- map ((10 :: Word64) ^) [(6 :: Word64)..7] ] +
+ examples/MoveString.hs view
@@ -0,0 +1,75 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}++import Control.Concurrent.RCU.MODE+import Control.Concurrent.RCU.Class+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 :: MonadReading (SRef s) (m s) => [a] -> List s a -> m s [a]+snapshot acc Nil = return $ reverse acc+snapshot acc (Cons x rn) = snapshot (x : acc) =<< readSRef rn++reader :: Int -> [[a]] -> SRef s (List s a) -> RCU s [[a]]+reader 0 acc _ = return $ reverse acc+reader n acc hd = do+ l <- reading $ snapshot [] =<< readSRef hd+ reader (n - 1) (l : acc) hd++{-+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 +-}++moveDback :: SRef s (List s Char) -> WritingRCU s ()+moveDback rl = do+ Cons _a rb <- readSRef rl+ Cons _b rc <- readSRef rb+ -- duplicate pointer to B+ rb' <- copySRef rb+ Cons c rd <- readSRef rc+ ne <- readSRef rd+ -- link in a new C after A+ writeSRef rb $ Cons c rb'+ -- any reader who starts during this grace period + -- sees either "ABCDE" or "ACBCDE"+ synchronize+ -- unlink the old C+ writeSRef rc ne++testList :: RCU s (SRef s (List s Char))+testList = do+ tl <- newSRef Nil+ c1 <- newSRef $ Cons 'E' tl+ c2 <- newSRef $ Cons 'D' c1+ c3 <- newSRef $ Cons 'C' c2+ c4 <- newSRef $ Cons 'B' c3+ newSRef $ Cons 'A' c4++compactShow :: (Show a, Eq a) => [a] -> String+compactShow xs = intercalate ", " $ map (\xs' -> show (length xs') ++ " x " ++ show (head xs')) $ group xs++main :: IO ()+main = do + outs <- runRCU $ do+ -- initialize list+ hd <- testList+ -- spawn 8 readers, each records 100000 snapshots of the list+ rts <- replicateM 8 $ forking $ reader 100000 [] hd+ -- spawn a writer to move a node from a later position to an earlier position+ wt <- forking $ writing $ moveDback hd+ + -- wait for the readers to finish and print snapshots+ outs <- forM rts $ \rt -> do + v <- joining rt+ return $ show (rcuThreadId rt) ++ ": " ++ compactShow v+ -- wait for the writer to finish+ joining wt+ return outs+ forM_ outs putStrLn
− examples/MoveStringQSBR.hs
@@ -1,73 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-import Control.Concurrent.RCU.QSBR-import Control.Concurrent.RCU.Class-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 :: MonadReading (SRef s) (m s) => [a] -> List s a -> m s [a]-snapshot acc Nil = return $ reverse acc-snapshot acc (Cons x rn) = snapshot (x : acc) =<< readSRef rn--reader :: Int -> [[a]] -> SRef s (List s a) -> RCU s [[a]]-reader 0 acc _ = return $ reverse acc-reader n acc hd = do- l <- reading $ snapshot [] =<< readSRef hd- reader (n - 1) (l : acc) hd--{--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 --}--moveDback :: SRef s (List s Char) -> WritingRCU s ()-moveDback rl = do- Cons _a rb <- readSRef rl- Cons _b rc <- readSRef rb- -- duplicate pointer to B- rb' <- copySRef rb- Cons c rd <- readSRef rc- ne <- readSRef rd- -- link in a new C after A- writeSRef rb $ Cons c rb'- -- any reader who starts during this grace period - -- sees either "ABCDE" or "ACBCDE"- synchronize- -- unlink the old C- writeSRef rc ne--testList :: RCU s (SRef s (List s Char))-testList = do- tl <- newSRef Nil- c1 <- newSRef $ Cons 'E' tl- c2 <- newSRef $ Cons 'D' c1- c3 <- newSRef $ Cons 'C' c2- c4 <- newSRef $ Cons 'B' c3- newSRef $ Cons 'A' c4--compactShow :: (Show a, Eq a) => [a] -> String-compactShow xs = intercalate ", " $ map (\xs' -> show (length xs') ++ " x " ++ show (head xs')) $ group xs--main :: IO ()-main = do - outs <- runRCU $ do- -- initialize list- hd <- testList- -- spawn 8 readers, each records 100000 snapshots of the list- rts <- replicateM 8 $ forking $ reader 100000 [] hd- -- spawn a writer to move a node from a later position to an earlier position- wt <- forking $ writing $ moveDback hd- - -- wait for the readers to finish and print snapshots- outs <- forM rts $ \rt -> do - v <- joining rt- return $ show (rcuThreadId rt) ++ ": " ++ compactShow v- -- wait for the writer to finish- joining wt- return outs- forM_ outs putStrLn
− examples/MoveStringSTM.hs
@@ -1,73 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-import Control.Concurrent.MVar (takeMVar)-import Control.Concurrent.RCU.STM-import Control.Concurrent.RCU.Class-import Control.Monad (forM, forM_, replicateM)-import Data.List (group, intercalate)-import Debug.Trace (trace)-import Prelude hiding (read)--data List s a = Nil | Cons a (SRef s (List s a))--snapshot :: MonadReading (SRef s) (m s) => [a] -> List s a -> m s [a]-snapshot acc Nil = return $ reverse acc-snapshot acc (Cons x rn) = snapshot (x : acc) =<< readSRef rn--reader :: Int -> [[a]] -> SRef s (List s a) -> RCU s [[a]]-reader 0 acc _ = return $ reverse acc-reader n acc head = do- l <- reading $ snapshot [] =<< readSRef head- reader (n - 1) (l : 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 --moveDback :: SRef s (List s Char) -> WritingRCU s ()-moveDback rl = do- Cons a rb <- readSRef rl- Cons b rc <- readSRef rb- -- duplicate pointer to B- rb' <- copySRef rb- Cons c rd <- readSRef rc- ne <- readSRef rd- -- link in a new C after A- writeSRef rb $ Cons c rb'- -- any reader who starts during this grace period - -- sees either "ABCDE" or "ACBCDE"- synchronize- -- unlink the old C- writeSRef rc ne--testList :: RCU s (SRef s (List s Char))-testList = do- tail <- newSRef Nil- c1 <- newSRef $ Cons 'E' tail- c2 <- newSRef $ Cons 'D' c1- c3 <- newSRef $ Cons 'C' c2- c4 <- newSRef $ Cons 'B' c3- newSRef $ Cons 'A' c4--compactShow :: (Show a, Eq a) => [a] -> String-compactShow xs = intercalate ", " $ map (\xs -> show (length xs) ++ " x " ++ show (head xs)) $ group xs--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 $ reader 100000 [] head- -- spawn a writer to move a node from a later position to an earlier position- wt <- forking $ writing $ moveDback head- - -- wait for the readers to finish and print snapshots- outs <- forM rts $ \rt -> do - v <- joining rt- return $ show (rcuThreadId rt) ++ ": " ++ compactShow v- -- wait for the writer to finish- joining wt- return outs- forM_ outs putStrLn
+ examples/TimeSynchronize.hs view
@@ -0,0 +1,206 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+import Control.Concurrent+import Control.Concurrent.RCU.MODE.Internal+import Control.Concurrent.RCU.Class+import Control.DeepSeq (force)+import Control.Exception (evaluate)+import Control.Monad+import Data.Bits ((.&.), (.|.), shiftL)+import Data.List (intercalate)+import Data.Monoid ((<>))+import Data.Word (Word64)+import Options.Applicative (auto, execParser, fullDesc, help, info, long, metavar, option, progDesc, short)+import Prelude hiding (read)++#if UNBOUND+import Data.Time (UTCTime(..), Day(..), NominalDiffTime, diffUTCTime, getCurrentTime)++type TimeT = NominalDiffTime++timer :: IO UTCTime+timer = getCurrentTime++timerDiff :: UTCTime -> UTCTime -> TimeT+timerDiff = diffUTCTime++timeZero :: TimeT+timeZero = let t = UTCTime (ModifiedJulianDay 0) 0 in t `diffUTCTime` t+#else+import System.CPUTime.Rdtsc (rdtsc)++type TimeT = Word64++timer :: IO Word64+timer = rdtsc++timerDiff :: TimeT -> TimeT -> TimeT+timerDiff = (-)++timeZero :: TimeT+timeZero = 0+#endif++data List s a = Nil | Cons a (SRef s (List s a))++-- | Checks whether the list contains the same bit twice.+-- Does not short-circuit, so all read-side critical sections+-- have similar memory access patterns and durations.+checkForDup :: MonadReading (SRef s) (m s) => (Word64, Bool) -> List s Word64 -> m s Bool+checkForDup (_, dup) Nil = return dup+checkForDup (acc, dup) (Cons x rn) = checkForDup (acc .|. x, dup || acc .&. x /= 0) =<< readSRef rn++--snapshot :: MonadReading (SRef s) (m s) => [a] -> List s a -> m s [a]+--snapshot acc Nil = return $ reverse acc+--snapshot acc (Cons x rn) = snapshot (x : acc) =<< readSRef rn++reader :: SRef s Bool -> Integer -> SRef s (List s Word64) -> RCU s Integer+reader rf !acc hd = do+ (acc', flag) <- reading $ do dup <- checkForDup (0, False) =<< readSRef hd + --when dup $ do+ -- xs <- snapshot [] =<< readSRef hd+ -- trace (show xs) $ return ()+ flag <- readSRef rf+ return (if dup then succ acc else acc, flag)+ if flag+ then return acc'+ else reader rf acc' hd++writer :: Int -> WritingRCU s TimeT -> WritingRCU s TimeT+writer n m = do+#if MEASURE_SYNCHRONIZE+ helper n m timeZero+ where helper 0 _ !acc = return acc+ helper !n m !acc = do d <- m+ helper (pred n) m (acc + d)+#else+ replicateM_ n m+ return timeZero+#endif+ ++moveDback :: SRef s (List s a) -> WritingRCU s TimeT+moveDback rl = WritingRCU $ \ s -> do+ (rc, ne) <- flip runWritingRCU s $ do+ Cons _a rb <- readSRef rl+ Cons _b rc <- readSRef rb+ -- duplicate pointer to B+ rb' <- copySRef rb+ Cons c rd <- readSRef rc+ ne <- readSRef rd+ -- link in a new C after A+ writeSRef rb $ Cons c rb'+ return (rc, ne)+#if MEASURE_SYNCHRONIZE+ beg <- timer+#endif+ -- any reader who starts during this grace period + -- sees either "ABCDE" or "ACBCDE"+ runWritingRCU synchronize s+#if MEASURE_SYNCHRONIZE+ end <- timer+ let d = end `timerDiff` beg+#else+ let d = timeZero+#endif+ -- unlink the old C+ flip runWritingRCU s $ do writeSRef rc ne+ return d++testList :: RCU s (SRef s (List s Word64))+testList = helper 4 =<< newSRef Nil+ where helper (- 1) tl = return tl+ helper i tl = helper (pred i) =<< newSRef (Cons (shiftL 1 i) tl)++data Opts = Opts { nReserved :: Integer + , nUpdates :: Integer }++main :: IO ()+main = do + Opts { nReserved, nUpdates } <- execParser opts+ nCaps <- getNumCapabilities+ putStrLn $ "nCaps: " ++ show nCaps+ let nReaders = fromIntegral nCaps - nReserved+ putStrLn $ "reserved: " ++ show nReserved ++ ", readers: " ++ show nReaders ++ ", updates: " ++ show nUpdates+ let nTotal = fromIntegral $ nUpdates * nReaders :: Double+ (ods, wfrd, wd, wfd) <- runOnRCU 0 $ RCU $ \ s -> do+ -- initialize list+ hd <- unRCU testList s+ -- initialize flag writer uses to stop readers+ rf <- unRCU (newSRef False) s+ -- spawn nReaders readers, each takes snapshots of the list until the writer has finished+ rts <- forM [2..fromIntegral nReaders + 1] $ \ i -> flip unRCU (s { rcuStatePinned = Just i }) $ forking $ reading $ ReadingRCU + $ \ s' -> do beg <- timer+ x <- evaluate . force =<< unRCU (reader rf 0 hd) s' -- how long do the snapshots take?+ mid <- timer+ _ <- evaluate . force $ x -- how long does walking over the result take?+ end <- timer+ return ( x+ , mid `timerDiff` beg+ , end `timerDiff` mid )+ -- spawn a writer to move a node from a later position to an earlier position nUpdates times+ wt <- flip unRCU (s { rcuStatePinned = Just 1 }) $ forking $ writing $ WritingRCU + $ \ s' -> do beg <- timer+ x <- evaluate . force =<< runWritingRCU (writer (fromIntegral nUpdates) (moveDback hd)) s'+ runWritingRCU (writeSRef rf True) s'+ mid <- timer+ _ <- evaluate . force $ x+ end <- timer+#if UNBOUND+ let d = x+#else+ let d = fromIntegral x :: Double+#endif+ return ( d / fromIntegral nUpdates+ , mid `timerDiff` beg+ , end `timerDiff` mid )+ -- wait for the readers to finish+ ods <- mapM (\ rt -> unRCU (joining rt) s) rts+ -- wait for the writer to finish+ (wfrd, wd, wfd) <- unRCU (joining wt) s+ return (ods, wfrd, wd, wfd)+ let outs = map a ods+ rds = map b ods :: [TimeT]+ rfds = map c ods :: [TimeT]+ a (x,_,_) = x+ b (_,y,_) = y+ c (_,_,z) = z+ putStrLn $ "dups by thread:" ++ (intercalate ", " $ zipWith (\ i dups -> show i ++ ": " ++ show dups) [(1 :: Integer)..] outs)+ putStrLn $ "average dups per update: " ++ show (fromIntegral (sum outs) / nTotal)+#if UNBOUND+ putStrLn $ "times in SECONDS"+#else+ putStrLn $ "times in TICKS"+#endif+ putStrLn $ "reader times: " ++ show rds+ putStrLn $ "reader evaluate . force times: " ++ show rfds+ putStrLn $ "writer time: " ++ show wd+ putStrLn $ "writer evaluate . force time: " ++ show wfd+#if UNBOUND+ let wtd = wd - wfd+#else+ let wtd = fromIntegral $ wd - wfd :: Double+#endif+ let aud = wtd / fromIntegral nUpdates+ putStrLn $ "average writer update time: " ++ show aud+#if MEASURE_SYNCHRONIZE+ putStrLn $ "average synchronize time: " ++ show wfrd+#endif+ where opts = info optsParser+ ( fullDesc+ <> progDesc "Measure writer latency for synchronize." )+ optsParser = Opts <$> nReservedParser <*> nUpdatesParser+ nReservedParser = option auto+ ( long "reserved"+ <> short 'r'+ <> metavar "N"+ <> help "N OS threads reserved for other stuff" )+ nUpdatesParser = option auto+ ( long "updates"+ <> short 'u'+ <> metavar "M"+ <> help "Writer thread performs M updates" )+
rcu.cabal view
@@ -1,6 +1,6 @@ name: rcu category: Data-version: 0.1+version: 0.2 license: BSD3 cabal-version: >= 1.22 license-file: LICENSE@@ -11,7 +11,7 @@ bug-reports: http://github.com/ekmett/rcu/issues copyright: Copyright (C) 2015 Edward A. Kmett, Theodore Rhys Cooper build-type: Custom-tested-with: GHC == 7.10.1, GHC == 7.10.2+tested-with: GHC == 7.10.3, GHC == 8.0.2 synopsis: Read-Copy-Update for Haskell description: Read-Copy-Update for Haskell @@ -39,20 +39,40 @@ default: False manual: True +-- Configure benchmarks to measure writer synchronize time at the expense of+-- increasing average update time.+flag measure-synchronize+ default: False+ manual: True++custom-setup+ setup-depends:+ base >= 4 && < 5,+ Cabal,+ cabal-doctest >= 1 && < 1.1+ library build-depends:- atomic-primops,+ atomic-primops >= 0.8, base >= 4.8 && < 5,+ ghc-prim >= 0.3, parallel >= 3.2 && < 3.3,- primitive,- transformers >= 0.4 && < 0.5+ primitive >= 0.6,+ transformers >= 0.4 && < 0.6 exposed-modules: Control.Concurrent.RCU.Class+ Control.Concurrent.RCU.GC+ Control.Concurrent.RCU.GC.Internal Control.Concurrent.RCU.QSBR Control.Concurrent.RCU.QSBR.Internal - ghc-options: -Wall -fwarn-tabs+ c-sources: cbits/pause.c+ include-dirs: cbits+ install-includes:+ pause.h+ pause_impl.h+ ghc-options: -Wall -fwarn-tabs -feager-blackholing hs-source-dirs: src default-language: Haskell2010 @@ -64,32 +84,371 @@ Control.Concurrent.RCU.STM.Internal executable MoveStringSTM- main-is: MoveStringSTM.hs+ main-is: MoveString.hs+ cpp-options: -DMODE=STM if !flag(unstable) buildable: False else- build-depends:- base >= 4.8 && < 5,- rcu,- stm >= 2.4.4 && < 2.5,- transformers >= 0.4 && < 0.5-+ build-depends: base, rcu, transformers hs-source-dirs: examples- ghc-options: -threaded -Wall -fwarn-tabs "-with-rtsopts=-N"+ ghc-options: -threaded -Wall -feager-blackholing -fwarn-tabs "-with-rtsopts=-N -qa -qb -qm -s" default-language: Haskell2010 executable MoveStringQSBR- main-is: MoveStringQSBR.hs+ main-is: MoveString.hs+ cpp-options: -DMODE=QSBR+ build-depends: base, rcu, transformers+ hs-source-dirs: examples+ ghc-options: -threaded -Wall -feager-blackholing -fwarn-tabs "-with-rtsopts=-N -qa -qb -qm -s"+ default-language: Haskell2010++executable MoveStringGC+ main-is: MoveString.hs+ cpp-options: -DMODE=GC+ build-depends: base, rcu, transformers+ hs-source-dirs: examples+ ghc-options: -threaded -Wall -feager-blackholing -fwarn-tabs "-with-rtsopts=-N -qa -qb -qm -s"+ default-language: Haskell2010++benchmark IncCounterExperiment+ main-is: IncCounterExperiment.hs+ type: exitcode-stdio-1.0 build-depends:+ base,+ criterion >= 1.1,+ ghc-prim,+ primitive,+ rcu,+ transformers++ hs-source-dirs: examples+ ghc-options: -threaded -Wall -feager-blackholing -fwarn-tabs "-with-rtsopts=-N -qa -qb -qm -s"+ default-language: Haskell2010++benchmark TimeSynchronizeQSBR+ main-is: TimeSynchronize.hs+ type: exitcode-stdio-1.0+ cpp-options: -DMODE=QSBR -DBENCHMARKS+ build-depends: base >= 4.8 && < 5,+ containers >= 0.5,+ deepseq >= 1.4.1,+ ghc-prim >= 0.3,+ optparse-applicative >= 0.11,+ primitive >= 0.6, rcu,- stm >= 2.4.4 && < 2.5,- transformers >= 0.4 && < 0.5+ rdtsc >= 1.3.0.1,+ transformers >= 0.4 && < 0.6 + if flag(measure-synchronize)+ cpp-options: -DMODE=QSBR -DBENCHMARKS -DMEASURE_SYNCHRONIZE++ c-sources: cbits/pause.c+ include-dirs: cbits+ install-includes:+ pause.h+ pause_impl.h hs-source-dirs: examples- ghc-options: -threaded -Wall -fwarn-tabs "-with-rtsopts=-N"+ ghc-options: -threaded -Wall -fwarn-tabs -feager-blackholing -rtsopts "-with-rtsopts=-N -qa -qb -qm -s" default-language: Haskell2010 +benchmark TimeSynchronizeGC+ main-is: TimeSynchronize.hs+ type: exitcode-stdio-1.0+ cpp-options: -DMODE=GC -DBENCHMARKS+ build-depends:+ base >= 4.8 && < 5,+ containers >= 0.5,+ deepseq >= 1.4.1,+ ghc-prim >= 0.3,+ optparse-applicative >= 0.11,+ primitive >= 0.6,+ rcu,+ rdtsc >= 1.3.0.1,+ transformers >= 0.4 && < 0.6++ if flag(measure-synchronize)+ cpp-options: -DMODE=GC -DBENCHMARKS -DMEASURE_SYNCHRONIZE++ c-sources: cbits/pause.c+ include-dirs: cbits+ install-includes:+ pause.h+ pause_impl.h+ hs-source-dirs: examples+ ghc-options: -threaded -Wall -fwarn-tabs -feager-blackholing -rtsopts "-with-rtsopts=-N -qa -qb -qm -s"+ default-language: Haskell2010++benchmark TimeSynchronizeQSBRUnbound+ main-is: TimeSynchronize.hs+ type: exitcode-stdio-1.0+ cpp-options: -DMODE=QSBR -DBENCHMARKS -DUNBOUND+ build-depends:+ base >= 4.8 && < 5,+ containers >= 0.5,+ deepseq >= 1.4.1,+ ghc-prim >= 0.3,+ optparse-applicative >= 0.11,+ primitive >= 0.6,+ rcu,+ time >= 1.5.0.1,+ transformers >= 0.4 && < 0.6++ if flag(measure-synchronize)+ cpp-options: -DMODE=QSBR -DBENCHMARKS -DUNBOUND -DMEASURE_SYNCHRONIZE++ c-sources: cbits/pause.c+ include-dirs: cbits+ install-includes:+ pause.h+ pause_impl.h+ hs-source-dirs: examples+ ghc-options: -threaded -Wall -fwarn-tabs -feager-blackholing -rtsopts "-with-rtsopts=-N -s"+ default-language: Haskell2010++benchmark TimeSynchronizeGCUnbound+ main-is: TimeSynchronize.hs+ type: exitcode-stdio-1.0+ cpp-options: -DMODE=GC -DBENCHMARKS -DUNBOUND+ build-depends:+ base >= 4.8 && < 5,+ containers >= 0.5,+ deepseq >= 1.4.1,+ ghc-prim >= 0.3,+ optparse-applicative >= 0.11,+ primitive >= 0.6,+ rcu,+ time >= 1.5.0.1,+ transformers >= 0.4 && < 0.6++ if flag(measure-synchronize)+ cpp-options: -DMODE=GC -DBENCHMARKS -DUNBOUND -DMEASURE_SYNCHRONIZE++ c-sources: cbits/pause.c+ include-dirs: cbits+ install-includes:+ pause.h+ pause_impl.h+ hs-source-dirs: examples+ ghc-options: -threaded -Wall -fwarn-tabs -feager-blackholing -rtsopts "-with-rtsopts=-N -s"+ default-language: Haskell2010++benchmark TimeSynchronizeQSBRSingleThread+ main-is: TimeSynchronize.hs+ type: exitcode-stdio-1.0+ cpp-options: -DMODE=QSBR -DBENCHMARKS -DUNBOUND+ build-depends:+ base >= 4.8 && < 5,+ containers >= 0.5,+ deepseq >= 1.4.1,+ ghc-prim >= 0.3,+ optparse-applicative >= 0.11,+ primitive >= 0.6,+ rcu,+ time >= 1.5.0.1,+ transformers >= 0.4 && < 0.6++ if flag(measure-synchronize)+ cpp-options: -DMODE=QSBR -DBENCHMARKS -DUNBOUND -DMEASURE_SYNCHRONIZE++ c-sources: cbits/pause.c+ include-dirs: cbits+ install-includes:+ pause.h+ pause_impl.h+ hs-source-dirs: examples+ ghc-options: -Wall -fwarn-tabs -feager-blackholing -rtsopts "-with-rtsopts=-s"+ default-language: Haskell2010++benchmark TimeSynchronizeGCSingleThread+ main-is: TimeSynchronize.hs+ type: exitcode-stdio-1.0+ cpp-options: -DMODE=GC -DBENCHMARKS -DUNBOUND+ build-depends:+ base >= 4.8 && < 5,+ containers >= 0.5,+ deepseq >= 1.4.1,+ ghc-prim >= 0.3,+ optparse-applicative >= 0.11,+ primitive >= 0.6,+ rcu,+ time >= 1.5.0.1,+ transformers >= 0.4 && < 0.6++ if flag(measure-synchronize)+ cpp-options: -DMODE=GC -DBENCHMARKS -DUNBOUND -DMEASURE_SYNCHRONIZE++ c-sources: cbits/pause.c+ include-dirs: cbits+ install-includes:+ pause.h+ pause_impl.h+ hs-source-dirs: examples+ ghc-options: -Wall -fwarn-tabs -feager-blackholing -rtsopts "-with-rtsopts=-s"+ default-language: Haskell2010++benchmark TimeSynchronizeQSBRPinned+ main-is: TimeSynchronize.hs+ type: exitcode-stdio-1.0+ cpp-options: -DMODE=QSBR -DBENCHMARKS+ build-depends:+ base >= 4.8 && < 5,+ containers >= 0.5,+ deepseq >= 1.4.1,+ ghc-prim >= 0.3,+ optparse-applicative >= 0.11,+ primitive >= 0.6,+ rcu,+ rdtsc >= 1.3.0.1,+ transformers >= 0.4 && < 0.6++ if flag(measure-synchronize)+ cpp-options: -DMODE=QSBR -DBENCHMARKS -DMEASURE_SYNCHRONIZE++ c-sources: cbits/pause.c+ include-dirs: cbits+ install-includes:+ pause.h+ pause_impl.h+ hs-source-dirs: examples+ ghc-options: -threaded -Wall -fwarn-tabs -feager-blackholing -rtsopts "-with-rtsopts=-N -qa -s"+ default-language: Haskell2010++benchmark TimeSynchronizeGCPinned+ main-is: TimeSynchronize.hs+ type: exitcode-stdio-1.0+ cpp-options: -DMODE=GC -DBENCHMARKS+ build-depends:+ base >= 4.8 && < 5,+ containers >= 0.5,+ deepseq >= 1.4.1,+ ghc-prim >= 0.3,+ optparse-applicative >= 0.11,+ primitive >= 0.6,+ rcu,+ rdtsc >= 1.3.0.1,+ transformers >= 0.4 && < 0.6++ if flag(measure-synchronize)+ cpp-options: -DMODE=GC -DBENCHMARKS -DMEASURE_SYNCHRONIZE++ c-sources: cbits/pause.c+ include-dirs: cbits+ install-includes:+ pause.h+ pause_impl.h+ hs-source-dirs: examples+ ghc-options: -threaded -Wall -fwarn-tabs -feager-blackholing -rtsopts "-with-rtsopts=-N -qa -s"+ default-language: Haskell2010++benchmark TimeSynchronizeQSBRnoGC+ main-is: TimeSynchronize.hs+ type: exitcode-stdio-1.0+ cpp-options: -DMODE=QSBR -DBENCHMARKS+ build-depends:+ base >= 4.8 && < 5,+ containers >= 0.5,+ deepseq >= 1.4.1,+ ghc-prim >= 0.3,+ optparse-applicative >= 0.11,+ primitive >= 0.6,+ rcu,+ rdtsc >= 1.3.0.1,+ transformers >= 0.4 && < 0.6++ if flag(measure-synchronize)+ cpp-options: -DMODE=QSBR -DBENCHMARKS -DMEASURE_SYNCHRONIZE++ c-sources: cbits/pause.c+ include-dirs: cbits+ install-includes:+ pause.h+ pause_impl.h+ hs-source-dirs: examples+ ghc-options: -threaded -Wall -fwarn-tabs -feager-blackholing -rtsopts "-with-rtsopts=-N -qa -qb -qm -A1g -I0 -s"+ default-language: Haskell2010++benchmark TimeSynchronizeGCnoGC+ main-is: TimeSynchronize.hs+ type: exitcode-stdio-1.0+ cpp-options: -DMODE=GC -DBENCHMARKS+ build-depends:+ base >= 4.8 && < 5,+ containers >= 0.5,+ deepseq >= 1.4.1,+ ghc-prim >= 0.3,+ optparse-applicative >= 0.11,+ primitive >= 0.6,+ rcu,+ rdtsc >= 1.3.0.1,+ transformers >= 0.4 && < 0.6++ if flag(measure-synchronize)+ cpp-options: -DMODE=GC -DBENCHMARKS -DMEASURE_SYNCHRONIZE++ c-sources: cbits/pause.c+ include-dirs: cbits+ install-includes:+ pause.h+ pause_impl.h+ hs-source-dirs: examples+ ghc-options: -threaded -Wall -fwarn-tabs -feager-blackholing -rtsopts "-with-rtsopts=-N -qa -qb -qm -A1g -I0 -s"+ default-language: Haskell2010++benchmark TimeSynchronizeQSBRnoGCPinned+ main-is: TimeSynchronize.hs+ type: exitcode-stdio-1.0+ cpp-options: -DMODE=QSBR -DBENCHMARKS+ build-depends:+ base >= 4.8 && < 5,+ containers >= 0.5,+ deepseq >= 1.4.1,+ ghc-prim >= 0.3,+ optparse-applicative >= 0.11,+ primitive >= 0.6,+ rcu,+ rdtsc >= 1.3.0.1,+ transformers >= 0.4 && < 0.6++ if flag(measure-synchronize)+ cpp-options: -DMODE=QSBR -DBENCHMARKS -DMEASURE_SYNCHRONIZE++ c-sources: cbits/pause.c+ include-dirs: cbits+ install-includes:+ pause.h+ pause_impl.h+ hs-source-dirs: examples+ ghc-options: -threaded -Wall -fwarn-tabs -feager-blackholing -rtsopts "-with-rtsopts=-N -qa -A1g -I0 -s"+ default-language: Haskell2010++benchmark TimeSynchronizeGCnoGCPinned+ main-is: TimeSynchronize.hs+ type: exitcode-stdio-1.0+ cpp-options: -DMODE=GC -DBENCHMARKS+ build-depends:+ base >= 4.8 && < 5,+ containers >= 0.5,+ deepseq >= 1.4.1,+ ghc-prim >= 0.3,+ optparse-applicative >= 0.11,+ primitive >= 0.6,+ rcu,+ rdtsc >= 1.3.0.1,+ transformers >= 0.4 && < 0.6++ if flag(measure-synchronize)+ cpp-options: -DMODE=GC -DBENCHMARKS -DMEASURE_SYNCHRONIZE++ c-sources: cbits/pause.c+ include-dirs: cbits+ install-includes:+ pause.h+ pause_impl.h+ hs-source-dirs: examples+ ghc-options: -threaded -Wall -fwarn-tabs -feager-blackholing -rtsopts "-with-rtsopts=-N -qa -A1g -I0 -s"+ default-language: Haskell2010+ test-suite doctests type: exitcode-stdio-1.0 main-is: doctests.hs@@ -102,9 +461,7 @@ else build-depends: base >= 4.8,- directory >= 1.0,- doctest >= 0.9.1,- filepath,+ doctest >= 0.11.1 && < 0.12, parallel test-suite hlint
src/Control/Concurrent/RCU/Class.hs view
@@ -159,7 +159,7 @@ 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)+ 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)
+ src/Control/Concurrent/RCU/GC.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE Trustworthy #-}+-----------------------------------------------------------------------------+-- |+-- Copyright : (C) 2015 Edward Kmett, Paul Khuong and Ted Cooper+-- License : BSD-style (see the file LICENSE)+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Ted Cooper <anthezium@gmail.com>+-- Stability : experimental+-- Portability : non-portable+--+-- Unfenced QSBR w/ Finalizer-Based Fallback Reclamation+-----------------------------------------------------------------------------+module Control.Concurrent.RCU.GC+ ( SRef+ , RCU, runRCU+ , MonadNew(..)+ , MonadReading(..)+ , MonadWriting(..)+ , MonadRCU(..)+ -- * Implementation Details+ , ReadingRCU+ , WritingRCU+ , RCUThread(rcuThreadId)+ ) where++import Control.Concurrent.RCU.Class+import Control.Concurrent.RCU.GC.Internal
+ src/Control/Concurrent/RCU/GC/Internal.hs view
@@ -0,0 +1,334 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# OPTIONS_HADDOCK not-home #-}+-----------------------------------------------------------------------------+-- |+-- Copyright : (C) 2015 Edward Kmett, Paul Khuong and Ted Cooper+-- License : BSD-style (see the file LICENSE)+-- Maintainer : Edward Kmett <ekmett@gmail.com>,+-- Ted Cooper <anthezium@gmail.com>+-- Stability : experimental+-- Portability : non-portable+--+-- QSBR-based RCU+-----------------------------------------------------------------------------+module Control.Concurrent.RCU.GC.Internal+ ( SRef(..)+ , RCUThread(..)+ , RCU(..)+ , runRCU+ , runOnRCU+ , ReadingRCU(..)+ , WritingRCU(..)+ , RCUState(..)+#if BENCHMARKS+ , unRCU+ , runWritingRCU+ , runReadingRCU+ , writeSRefIO+#endif+ ) where++import Control.Applicative+import Control.Concurrent+import Control.Concurrent.RCU.Class+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Primitive+import Control.Parallel+import Data.Atomics+import Data.IORef+import Data.List+import Data.Primitive+import Prelude hiding (read, Read)+import System.Mem+++--------------------------------------------------------------------------------+-- * Shared References+--------------------------------------------------------------------------------++-- | Shared references+newtype SRef s a = SRef { unSRef :: IORef a }+ deriving Eq++newSRefIO :: a -> IO (IORef a)+newSRefIO = newIORef+{-# INLINE newSRefIO #-}++readSRefIO :: IORef a -> IO a+readSRefIO = readIORef+{-# INLINE readSRefIO #-}++writeSRefIO :: IORef a -> a -> IO ()+writeSRefIO r a = do a `pseq` writeBarrier+ writeIORef r a+{-# INLINE writeSRefIO #-}++--------------------------------------------------------------------------------+-- * Shared state+--------------------------------------------------------------------------------++-- | Counter for causal ordering.+newtype Counter = Counter (MutableByteArray RealWorld)++instance Eq Counter where+ Counter m == Counter n = sameMutableByteArray m n++newCounter :: Int -> IO Counter+newCounter w = do+ b <- newByteArray 8+ writeByteArray b 0 w+ return (Counter b)+{-# INLINE newCounter #-}++readCounter :: Counter -> IO Int+readCounter (Counter c) = readByteArray c 0+{-# INLINE readCounter #-}++writeCounter :: Counter -> Int -> IO ()+writeCounter (Counter c) w = writeByteArray c 0 w+{-# INLINE writeCounter #-}++incCounter :: Counter -> IO Int+incCounter (Counter c) = do+ x <- fetchAddIntArray c 0 1+ return $! x + 1+{-# INLINE incCounter #-}++newtype Version = Version (IORef ())++newVersion :: IO Version+newVersion = Version <$> newIORef ()++-- | State for an RCU computation.+data RCUState = RCUState+ { -- | Global state+ rcuStateGlobalCounter :: {-# UNPACK #-} !Counter+ , rcuStateGlobalVersion :: {-# UNPACK #-} !(IORef Version)+ , rcuStateThreadCountersV :: {-# UNPACK #-} !(MVar [Counter])+ , rcuStateWriterLockV :: {-# UNPACK #-} !(MVar ())+ -- | Thread state+ , rcuStateMyCounter :: {-# UNPACK #-} !Counter -- each thread's state gets its own counter+ , rcuStatePinned :: !(Maybe Int)+ }++--------------------------------------------------------------------------------+-- * Read-Side Critical Sections+--------------------------------------------------------------------------------++-- | This is the basic read-side critical section for an RCU computation+newtype ReadingRCU s a = ReadingRCU { runReadingRCU :: RCUState -> IO a }+ deriving Functor++instance Applicative (ReadingRCU s) where+ pure a = ReadingRCU $ \ _ -> pure a+ ReadingRCU mf <*> ReadingRCU ma = ReadingRCU $ \ s -> mf s <*> ma s++instance Monad (ReadingRCU s) where+ return a = ReadingRCU $ \ _ -> pure a+ ReadingRCU m >>= f = ReadingRCU $ \ s -> do+ a <- m s+ runReadingRCU (f a) s+ fail s = ReadingRCU $ \ _ -> fail s++instance Alternative (ReadingRCU s) where+ empty = ReadingRCU $ \ _ -> empty+ ReadingRCU ma <|> ReadingRCU mb = ReadingRCU $ \s -> ma s <|> mb s++instance MonadPlus (ReadingRCU s) where+ mzero = ReadingRCU $ \ _ -> mzero+ ReadingRCU ma `mplus` ReadingRCU mb = ReadingRCU $ \s -> ma s `mplus` mb s++instance MonadNew (SRef s) (ReadingRCU s) where+ newSRef a = ReadingRCU $ \_ -> SRef <$> newSRefIO a++instance MonadReading (SRef s) (ReadingRCU s) where+ readSRef (SRef r) = ReadingRCU $ \ _ -> readSRefIO r+ {-# INLINE readSRef #-}++--------------------------------------------------------------------------------+-- * Write-Side Critical Sections+--------------------------------------------------------------------------------++-- | This is the basic write-side critical section for an RCU computation+newtype WritingRCU s a = WritingRCU { runWritingRCU :: RCUState -> IO a }+ deriving Functor++instance Applicative (WritingRCU s) where+ pure a = WritingRCU $ \ _ -> pure a+ WritingRCU mf <*> WritingRCU ma = WritingRCU $ \ s -> mf s <*> ma s++instance Monad (WritingRCU s) where+ return a = WritingRCU $ \ _ -> pure a+ WritingRCU m >>= f = WritingRCU $ \ s -> do+ a <- m s+ runWritingRCU (f a) s+ fail s = WritingRCU $ \ _ -> fail s++instance Alternative (WritingRCU s) where+ empty = WritingRCU $ \ _ -> empty+ WritingRCU ma <|> WritingRCU mb = WritingRCU $ \s -> ma s <|> mb s++instance MonadPlus (WritingRCU s) where+ mzero = WritingRCU $ \ _ -> mzero+ WritingRCU ma `mplus` WritingRCU mb = WritingRCU $ \s -> ma s `mplus` mb s++instance MonadNew (SRef s) (WritingRCU s) where+ newSRef a = WritingRCU $ \_ -> SRef <$> newSRefIO a++instance MonadReading (SRef s) (WritingRCU s) where+ readSRef (SRef r) = WritingRCU $ \ _ -> readSRefIO r+ {-# INLINE readSRef #-}++instance MonadWriting (SRef s) (WritingRCU s) where+ writeSRef (SRef r) a = WritingRCU $ \ _ -> writeSRefIO r a+ {-# INLINE writeSRef #-}+ synchronize = WritingRCU synchronizeIO++synchronizeIO :: RCUState -> IO ()+synchronizeIO s = do+ withMVar (rcuStateThreadCountersV s) $ \ threadCounters -> do+ gc' <- incCounter (rcuStateGlobalCounter s)+ writeCounter (rcuStateMyCounter s) gc'+ let waitForThreads i xxs@(x:xs)+ | i > 2000 = return True+ | otherwise = do+ tc <- readCounter x+ if tc == gc' then waitForThreads (i + 1) xs+ else do+ threadDelay 1+ waitForThreads (i + 1) xxs+ waitForThreads _ [] = return False+ bad <- waitForThreads (0 :: Int) threadCounters+ when bad $ do+ -- slow path+ m <- newEmptyMVar+ stuff s m+ performMinorGC+ sitAndSpin m+ storeLoadBarrier++stuff :: RCUState -> MVar () -> IO ()+stuff s m = do+ Version v <- readIORef (rcuStateGlobalVersion s)+ v' <- newVersion+ atomicWriteIORef (rcuStateGlobalVersion s) v'+ _ <- mkWeakIORef v $ putMVar m ()+ return ()+{-# NOINLINE stuff #-}++-- This is awful. It should just takeMVar+sitAndSpin :: MVar () -> IO ()+sitAndSpin m = tryTakeMVar m >>= \case+ Just () -> return ()+ Nothing -> do+ performMajorGC+ sitAndSpin m++--------------------------------------------------------------------------------+-- * 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. Writers are+-- serialized using an MVar, readers are able to proceed while writers are+-- updating.+newtype RCU s a = RCU { unRCU :: RCUState -> 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 (SRef s) (RCU s) where+ newSRef a = RCU $ \_ -> SRef <$> newSRefIO 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 (SRef 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 $ \ s -> do+ result <- newEmptyMVar+ gc <- readCounter (rcuStateGlobalCounter s)+ threadCounter <- newCounter gc+ modifyMVar_ (rcuStateThreadCountersV s) $ return . (threadCounter :)+ tid <- forkIO $ do+ x <- m $ s { rcuStateMyCounter = threadCounter }+ putMVar result x+ modifyMVar_ (rcuStateThreadCountersV s) $ return . delete threadCounter+ return (RCUThread tid result)+ {-# INLINE forking #-}++ joining (RCUThread _ m) = RCU $ \ _ -> readMVar m+ {-# INLINE joining #-}++ reading (ReadingRCU m) = RCU $ \ s -> do+ v <- readIORef (rcuStateGlobalVersion s)+ x <- m s+ touch v+ writeCounter (rcuStateMyCounter s) =<< readCounter (rcuStateGlobalCounter s)+ return x+ {-# INLINE reading #-}++ writing (WritingRCU m) = RCU $ \ s -> do+ -- Acquire the writer-serializing lock.+ takeMVar (rcuStateWriterLockV s)+ x <- m s+ synchronizeIO s+ putMVar (rcuStateWriterLockV s) ()+ return x+ {-# 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+ v <- newVersion+ unRCU m =<< RCUState <$> newCounter 0+ <*> newIORef v+ <*> newMVar []+ <*> newMVar ()+ <*> newCounter 0+ <*> pure Nothing+{-# INLINE runRCU #-}++-- | Run an RCU computation in a thread pinned to a particular core.+runOnRCU :: Int -> (forall s. RCU s a) -> IO a+runOnRCU i m = do+ v <- newVersion+ unRCU m =<< RCUState <$> newCounter 0+ <*> newIORef v+ <*> newMVar []+ <*> newMVar ()+ <*> newCounter 0+ <*> pure (Just i)+{-# INLINE runOnRCU #-}
src/Control/Concurrent/RCU/QSBR/Internal.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE TypeFamilies #-}@@ -5,17 +7,17 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# OPTIONS_HADDOCK not-home #-} ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2015 Edward Kmett and Ted Cooper -- License : BSD-style (see the file LICENSE)--- Maintainer : Edward Kmett <ekmett@gmail.com>, +-- Maintainer : Edward Kmett <ekmett@gmail.com>, -- Ted Cooper <anthezium@gmail.com> -- Stability : experimental -- Portability : non-portable@@ -27,9 +29,17 @@ , RCUThread(..) , RCU(..) , runRCU+ , runOnRCU , ReadingRCU(..) , WritingRCU(..) , RCUState(..)+#if BENCHMARKS+ , unRCU+ , runWritingRCU+ , runReadingRCU+ , writeSRefIO+ , RCUState(..)+#endif ) where import Control.Applicative@@ -37,13 +47,18 @@ import Control.Concurrent.RCU.Class import Control.Monad import Control.Monad.IO.Class+import Control.Monad.Primitive import Control.Parallel-import Data.Atomics +import Data.Atomics+import Data.IORef import Data.List-import Data.IORef -import Data.Word+import Data.Primitive+import Foreign+ import Prelude hiding (read, Read) +foreign import ccall unsafe "pause.h" pause :: IO ()+ -------------------------------------------------------------------------------- -- * Shared References --------------------------------------------------------------------------------@@ -70,8 +85,11 @@ -------------------------------------------------------------------------------- -- | Counter for causal ordering.-type Counter = IORef Word64+newtype Counter = Counter (MutableByteArray RealWorld) +instance Eq Counter where+ Counter m == Counter n = sameMutableByteArray m n+ offline :: Word64 offline = 0 @@ -79,32 +97,40 @@ online = 1 -- counterInc :: Word64--- counterInc = 2 -- online threads will never overflow to 1+-- counterInc = 2 -- online threads will never overflow to 0 newCounter :: IO Counter-newCounter = newIORef online+newCounter = do+ b <- newByteArray 8+ writeByteArray b 0 online+ return (Counter b)+{-# INLINE newCounter #-} readCounter :: Counter -> IO Word64-readCounter = readIORef+readCounter (Counter c) = readByteArray c 0 {-# INLINE readCounter #-} writeCounter :: Counter -> Word64 -> IO ()-writeCounter c !i = writeIORef c i+writeCounter (Counter c) w = writeByteArray c 0 w {-# INLINE writeCounter #-} incCounter :: Counter -> IO Word64-incCounter c = do !x <- succ <$> readIORef c- writeCounter c x- return x+incCounter c = do+ x <- (+ 2) <$> readCounter c+ writeCounter c x+ return x {-# INLINE incCounter #-}- -- | State for an RCU computation. data RCUState = RCUState- { rcuStateGlobalCounter :: {-# UNPACK #-} !Counter- , rcuStateMyCounter :: {-# UNPACK #-} !Counter -- each thread's state gets its own counter- , rcuStateThreadCountersV :: {-# UNPACK #-} !(MVar [Counter])- , rcuStateWriterLockV :: {-# UNPACK #-} !(MVar ())+ { -- | Global state+ rcuStateGlobalCounter :: {-# UNPACK #-} !Counter+ , rcuStateThreadCountersR :: {-# UNPACK #-} !(IORef [Counter])+ , rcuStateThreadCountersLockV :: {-# UNPACK #-} !(MVar ())+ , rcuStateWriterLockV :: {-# UNPACK #-} !(MVar ())+ -- | Thread state+ , rcuStateMyCounter :: {-# UNPACK #-} !Counter+ , rcuStatePinned :: !(Maybe Int) } --------------------------------------------------------------------------------@@ -112,7 +138,7 @@ -------------------------------------------------------------------------------- -- | This is the basic read-side critical section for an RCU computation-newtype ReadingRCU s a = ReadingRCU { runReadingRCU :: RCUState -> IO a } +newtype ReadingRCU s a = ReadingRCU { runReadingRCU :: RCUState -> IO a } deriving Functor instance Applicative (ReadingRCU s) where@@ -180,51 +206,39 @@ {-# INLINE writeSRef #-} synchronize = WritingRCU synchronizeIO -synchronizeIO :: RCUState -> IO () +synchronizeIO :: RCUState -> IO () synchronizeIO RCUState { rcuStateGlobalCounter , rcuStateMyCounter- , rcuStateThreadCountersV } = do+ , rcuStateThreadCountersR+ , rcuStatePinned } = do -- Get this thread's counter. mc <- readCounter rcuStateMyCounter- storeLoadBarrier -- If this thread is not offline already, take it offline. when (mc /= offline) $ writeCounter rcuStateMyCounter offline -- Loop through thread counters, waiting for online threads to catch up- -- and skipping offline threads. - -- TODO: urcu acquires rcu_gp_lock here, and holds it until the writer has - -- updated the global counter AND finished waiting for readers. I think we may be able- -- to avoid holding the lock while waiting for readers as long as we- -- allow thread counters to exceed gc' (this is the case currently). - -- Maybe urcu holds the lock to prevent multiple readers from busy-waiting- -- on the same shared array? All they're doing is loading, so I'm not sure- -- why that would be a bad thing... This issue, (and having a lock here at all)- -- is moot until we remove the big lock around write-side critical sections.- -- This is worth pinging Mathieu about.- -- So, TODO: Remove this lock, add a storeLoadBarrier after rcuStateMyCounter update.- gc' <- withMVar rcuStateThreadCountersV $ \ threadCounters -> do- -- Increment the global counter.- gc' <- incCounter rcuStateGlobalCounter- writeBarrier- -- Wait for each online reader to copy the new global counter.- let waitForThread i threadCounter = do- tc <- readCounter threadCounter- when (tc /= offline && tc < gc') $ do - -- urcu puts the thread on a futex wait queue once per Int32 overflow- -- in this loop. - threadDelay 1 -- TODO: Busy-wait for a while before sleeping.-- storeLoadBarrier -- This works on all systems, even those with - -- incoherent caches, but slows down writers - -- unnecessarily on cache-coherent systems. - -- TODO: On cache-coherent systems, - -- figure out how to make GHC emit e.g. "rep; nop"- -- to tell the CPU we're in a busy-wait loop. - -- urcu uses "caa_cpu_relax()" decorated with a compiler- -- reordering barrier in this case.- waitForThread (i + 1) threadCounter- forM_ threadCounters (waitForThread (0 :: Int))- return gc'+ -- and skipping offline threads.+ threadCounters <- readSRefIO rcuStateThreadCountersR+ -- Increment the global counter.+ gc' <- incCounter rcuStateGlobalCounter+ let busyWaitPeriod = case rcuStatePinned of Just _ -> 1000+ Nothing -> 2+ -- Wait for each online reader to copy the new global counter.+ let waitForThread !(n :: Word64) threadCounter = do+ tc <- readCounter threadCounter+ when (tc /= offline && tc /= gc') $ do+ -- spin for 999 iterations before sleeping+ if n `mod` busyWaitPeriod == 0+ then yield+ else pause -- TODO: Figure out how to make GHC emit e.g. "rep; nop"+ -- inline to tell the CPU we're in a busy-wait loop.+ -- For now, FFI call a C function with inline "rep; nop".+ -- This approach is apparently about 10 times heavier than+ -- just inlining the instruction in your program text :(+ -- urcu uses "caa_cpu_relax()" decorated with a compiler+ -- reordering barrier in this case.+ waitForThread (succ n) threadCounter+ forM_ threadCounters (waitForThread 1) when (mc /= offline) $ writeCounter rcuStateMyCounter gc' storeLoadBarrier @@ -264,17 +278,23 @@ type Reading (RCU s) = ReadingRCU s type Writing (RCU s) = WritingRCU s type Thread (RCU s) = RCUThread s- forking (RCU m) = RCU $ \ s@RCUState { rcuStateThreadCountersV } -> do+ forking (RCU m) = RCU $ \ s@RCUState { rcuStateThreadCountersLockV+ , rcuStateThreadCountersR+ , rcuStatePinned } -> do -- Create an MVar the new thread can use to return a result. result <- newEmptyMVar -- Create a counter for the new thread, and add it to the list. threadCounter <- newCounter -- Wouldn't <$$> be nice here...- modifyMVar_ rcuStateThreadCountersV $ return . (threadCounter :)+ withMVar rcuStateThreadCountersLockV $ \ _ -> writeSRefIO rcuStateThreadCountersR . (threadCounter :) =<< readSRefIO rcuStateThreadCountersR+ storeLoadBarrier -- Spawn the new thread, whose return value goes in @result@.- tid <- forkIO $ do+ let frk = case rcuStatePinned of+ Just i -> forkOn i+ Nothing -> forkIO+ tid <- frk $ do x <- m $ s { rcuStateMyCounter = threadCounter } putMVar result x @@ -282,7 +302,7 @@ -- and remove this counter from the list writers poll. writeBarrier writeCounter threadCounter offline- modifyMVar_ rcuStateThreadCountersV $ return . delete threadCounter+ withMVar rcuStateThreadCountersLockV $ \ _ -> writeSRefIO rcuStateThreadCountersR . delete threadCounter =<< readSRefIO rcuStateThreadCountersR return (RCUThread tid result) {-# INLINE forking #-} @@ -291,23 +311,24 @@ reading (ReadingRCU m) = RCU $ \ s@RCUState { rcuStateMyCounter , rcuStateGlobalCounter } -> do- mc <- readCounter rcuStateMyCounter+ --mc <- readCounter rcuStateMyCounter -- If this thread was offline, take a snapshot of the global counter so -- writers will wait.- when (mc == offline) $ do- writeCounter rcuStateMyCounter =<< readCounter rcuStateGlobalCounter - -- Make sure that the counter goes online before reads begin.- storeLoadBarrier- + --when (mc == offline) $ do+ writeCounter rcuStateMyCounter =<< readCounter rcuStateGlobalCounter+ -- Make sure that the counter goes online before reads begin.+ storeLoadBarrier+ -- Run a read-side critical section. x <- m s- + -- Announce a quiescent state after the read-side critical section. -- TODO: Make this tunable/optional. storeLoadBarrier- writeCounter rcuStateMyCounter =<< readCounter rcuStateGlobalCounter+ --writeCounter rcuStateMyCounter =<< readCounter rcuStateGlobalCounter+ writeCounter rcuStateMyCounter offline storeLoadBarrier- + -- Return the result of the read-side critical section. return x {-# INLINE reading #-}@@ -334,6 +355,21 @@ -- | Run an RCU computation. runRCU :: (forall s. RCU s a) -> IO a-runRCU m = do- unRCU m =<< RCUState <$> newCounter <*> newCounter <*> newMVar [] <*> newMVar ()+runRCU m =+ unRCU m =<< RCUState <$> newCounter+ <*> newIORef []+ <*> newMVar ()+ <*> newMVar ()+ <*> newCounter+ <*> pure Nothing {-# INLINE runRCU #-}++-- | Run an RCU computation in a thread pinned to a particular core.+runOnRCU :: Int -> (forall s. RCU s a) -> IO a+runOnRCU i m =+ unRCU m =<< RCUState <$> newCounter+ <*> newIORef []+ <*> newMVar ()+ <*> newMVar ()+ <*> newCounter+ <*> pure (Just i)
+ tests/doctests.hs view
@@ -0,0 +1,25 @@+-----------------------------------------------------------------------------+-- |+-- 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 (flags, pkgs, module_sources)+import Data.Foldable (traverse_)+import Test.DocTest++main :: IO ()+main = do+ traverse_ putStrLn args+ doctest args+ where+ args = flags ++ pkgs ++ module_sources
− tests/doctests.hsc
@@ -1,78 +0,0 @@-{-# 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