diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,6 @@ +## 0.1.1 [2017.01.22] +* Expose `Data.TLS.PThread.Internal`. Note that there are no API guarantees + whatsoever with this module, so use it with caution. +* Add `pthread` to `extra-libraries`. Without it, some systems suffer + from linker errors when using this library. +* Fix build on GHC 7.6 and 7.8. diff --git a/Data/TLS/GHC.hs b/Data/TLS/GHC.hs --- a/Data/TLS/GHC.hs +++ b/Data/TLS/GHC.hs @@ -17,11 +17,12 @@ , getTLS , allTLS , forEachTLS_ + , freeAllTLS + -- * Deprecated, backwards compatibility , freeTLS ) where import Control.Monad -import Control.Exception (evaluate) import Control.Concurrent import Data.Map.Strict as M import Data.IORef @@ -60,5 +61,6 @@ forM_ ls fn -- Nothing to do here... we haven't pinned anything. Normal GC is fine. -freeTLS _ = return () +freeAllTLS _ = + do return () diff --git a/Data/TLS/PThread.hs b/Data/TLS/PThread.hs --- a/Data/TLS/PThread.hs +++ b/Data/TLS/PThread.hs @@ -18,6 +18,8 @@ , getTLS , allTLS , forEachTLS_ + , freeAllTLS + -- * Deprecated, backwards compatibility , freeTLS ) where diff --git a/Data/TLS/PThread/Internal.hs b/Data/TLS/PThread/Internal.hs --- a/Data/TLS/PThread/Internal.hs +++ b/Data/TLS/PThread/Internal.hs @@ -3,17 +3,24 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ForeignFunctionInterface #-} --- Export EVERYTHING from this internal module. +-- | Like "Data.TLS.PThread", but this also exports internal functionality +-- not exposed in the public interface. +-- +-- There are no API guaranteees whatsoever for this module, so use it with +-- with caution. module Data.TLS.PThread.Internal where import Control.Monad import Control.Exception -import Data.Word import Data.IORef import Foreign.Ptr import Foreign.StablePtr import Foreign.Storable(Storable(sizeOf)) - + +#if !(MIN_VERSION_base(4,8,0)) +import Data.Word (Word) +#endif + #include "../TLS_Sig.hs" -------------------------------------------------------------------------------- @@ -27,7 +34,7 @@ foreign import ccall unsafe easy_make_pthread_key :: IO Key - + foreign import ccall unsafe pthread_getspecific :: Key -> IO (StablePtr a) @@ -36,7 +43,7 @@ foreign import ccall unsafe pthread_key_delete :: Key -> IO Int - + check_error :: () check_error = -- if get_pthread_key_size == sizeOf(0::Word) @@ -44,12 +51,12 @@ then () else error $ "Data.TLS.PThread: internal invariant broken! Expected pthread_key_t to be word-sized!\n" ++"Instead it was: "++show get_pthread_key_size - + {-# INLINE setspecific #-} setspecific :: Key -> StablePtr a -> IO () setspecific k p = do - code <- pthread_setspecific k p + code <- pthread_setspecific k p unless (code == 0) (error $ "pthread_setspecific returned error code: "++show code) {-# INLINE delete #-} @@ -59,15 +66,15 @@ -- putStrLn $ "KEY DELETED: "++show k unless (code == 0) (error $ "pthread_key_delete returned error code: "++show code) return () - - + + -------------------------------------------------------------------------------- -- | A thread-local variable of type `a`. data TLS a = TLS { key :: {-# UNPACK #-} !Key , mknew :: !(IO a) , allCopies :: {-# UNPACK #-} !(IORef [StablePtr a]) } - + mkTLS new = do evaluate check_error key <- easy_make_pthread_key @@ -86,15 +93,15 @@ else deRefStablePtr p -allTLS TLS{allCopies} = do +allTLS TLS{allCopies} = do ls <- readIORef allCopies mapM deRefStablePtr ls forEachTLS_ tls fn = do ls <- allTLS tls - forM_ ls fn + forM_ ls fn -freeTLS TLS{key,allCopies} = do +freeAllTLS TLS{key,allCopies} = do ls <- readIORef allCopies delete key mapM_ freeStablePtr ls diff --git a/Data/TLS/TLS_Sig.hs b/Data/TLS/TLS_Sig.hs --- a/Data/TLS/TLS_Sig.hs +++ b/Data/TLS/TLS_Sig.hs @@ -30,8 +30,22 @@ -- | Like `allTLS`, but apply a computation directly rather than -- building a list. forEachTLS_ :: TLS a -> (a -> IO ()) -> IO () - + + +-- | An alias for `freeAllTLS`. +freeTLS :: TLS a -> IO () +freeTLS = freeAllTLS +{-# DEPRECATED freeTLS "Replaced by freeAllTLS" #-} + -- | Release all copies of the TLS variable, across all threads. This -- does not guarantee the storage will be freed immediately, but it -- guarantees that the storage can be reclaimed in the future. -freeTLS :: TLS a -> IO () +-- +-- The TLS value is still usable after this call, but any future calls +-- to `getTLS` must initialize new state. +-- +-- Not thread safe. +freeAllTLS :: TLS a -> IO () + + + diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,21 @@ +# `thread-local-storage` +[![Hackage](https://img.shields.io/hackage/v/thread-local-storage.svg)][Hackage: thread-local-storage] +[![Hackage Dependencies](https://img.shields.io/hackage-deps/v/thread-local-storage.svg)](http://packdeps.haskellers.com/reverse/thread-local-storage) +[![Haskell Programming Language](https://img.shields.io/badge/language-Haskell-blue.svg)][Haskell.org] +[![BSD3 License](http://img.shields.io/badge/license-BSD3-brightgreen.svg)][tl;dr Legal: BSD3] + +[Hackage: thread-local-storage]: + http://hackage.haskell.org/package/thread-local-storage + "thread-local-storage package on Hackage" +[Haskell.org]: + http://www.haskell.org + "The Haskell Programming Language" +[tl;dr Legal: BSD3]: + https://tldrlegal.com/license/bsd-3-clause-license-%28revised%29 + "BSD 3-Clause License (Revised)" + +See .cabal file for description. + +Here are some example benchmark results (on an Ivy Bridge i7-3770), with a typical time of 10.4 nanoseconds to get to a TLS variable given one IO thread per OS thread: + +![example benchmarks](https://raw.githubusercontent.com/rrnewton/thread-local-storage/master/bench/example_results.png) diff --git a/bench/Main.hs b/bench/Main.hs --- a/bench/Main.hs +++ b/bench/Main.hs @@ -1,3 +1,4 @@ + {-# LANGUAGE BangPatterns #-} module Main where @@ -12,18 +13,18 @@ import Criterion.Types import Criterion.Main import Data.Atomics.Counter - + import Control.Monad import Control.Concurrent.MVar import Data.IORef import GHC.Conc -import System.Environment +import System.Environment -------------------------------------------------------------------------------- - + main :: IO () main = do numProc <- getNumProcessors - n <- getNumCapabilities + n <- getNumCapabilities when (n == 1) $ do putStrLn "HACK: using setNumCapabilities to bump it up... should set this in the .cabal" setNumCapabilities numProc numCap <- getNumCapabilities @@ -36,8 +37,8 @@ then words $ " --regress=allocated:iters --regress=bytesCopied:iters --regress=cycles:iters "++ " --regress=numGcs:iters --regress=mutatorWallSeconds:iters --regress=gcWallSeconds:iters "++ " --regress=cpuTime:iters " ++ - " -o tls_report.html " --- ++ " --raw tls_report.criterion " + " -o tls_report.html " +-- ++ " --raw tls_report.criterion " else args threadify fn = @@ -46,34 +47,34 @@ | threads <- [1..numCap*4], let suff = "_" ++ show threads ++"io_"++ show numCap++"os" ] - mkTests name mkTLS getTLS freeTLS = bgroup name + mkTests name mkTLS getTLS freeAllTLS = bgroup name [ -- bench ("counter/getTLS/incrCntr"++suff) $ -- benchPar0 threads (GHC.mkTLS (newCounter 0)) -- (\t -> incrCounter_ 1 =<< GHC.getTLS t) - threadify $ \ (threads,suff) -> + threadify $ \ (threads,suff) -> bench ("counter/getTLS/readIORef"++suff) $ benchPar0 threads (mkTLS (newIORef ())) (\t -> readIORef =<< getTLS t) - freeTLS + freeAllTLS ] - - withArgs args' $ defaultMain $ - [ mkTests "PThread" PT.mkTLS PT.getTLS PT.freeTLS - , mkTests "GHC" GHC.mkTLS GHC.getTLS GHC.freeTLS + + withArgs args' $ defaultMain $ + [ mkTests "PThread" PT.mkTLS PT.getTLS PT.freeAllTLS + , mkTests "GHC" GHC.mkTLS GHC.getTLS GHC.freeAllTLS ] {- bgroup "infrastructure" [ bench ("benchPar1"++suff) $ benchPar1 threads (return ()) , bench ("benchPar0"++suff) $ benchPar0 threads (return ()) (\_ -> return ()) --- , bench ("benchPar2"++suff) $ benchPar2 threads (return ()) - ], -} +-- , bench ("benchPar2"++suff) $ benchPar2 threads (return ()) + ], -} -- | ] where - + ---------------------------------------------------------------------------------------------------- benchPar0 :: Int -> IO a -> (a -> IO ()) -> (a -> IO ()) -> Benchmarkable @@ -87,7 +88,7 @@ let totalIters = (fromIntegral iters) * (max numCap numT) perThread = totalIters `quot` numT mvs <- forM [0..numT-1] $ \ n -> do - v <- newEmptyMVar + v <- newEmptyMVar _ <- forkOn n $ do rep perThread (fn x) putMVar v () return v @@ -100,13 +101,13 @@ -- | Benchmarking the same action on ALL of N threads. -- This version uses MVar synchronization. benchPar1 :: Int -> IO () -> Benchmarkable -benchPar1 num act = Benchmarkable $ \ iters -> do +benchPar1 num act = Benchmarkable $ \ iters -> do mvs <- forM [0..num-1] $ \ n -> do - v <- newEmptyMVar + v <- newEmptyMVar _ <- forkOn n $ do rep (fromIntegral iters) act putMVar v () return v - forM_ mvs takeMVar + forM_ mvs takeMVar {-# INLINE benchPar1 #-} -- | This version never blocks on an MVar. @@ -120,7 +121,7 @@ waitCounter forM_ [1..num-1] $ \ n -> forkOn n go go - + {-# INLINE benchPar2 #-} -- | My own forM for inclusive numeric ranges (not requiring deforestation optimizations). @@ -128,8 +129,8 @@ for_ start end _fn | start > end = error "for_: start is greater than end" for_ start end fn = loop start where - loop !i | i > end = return () - | otherwise = do fn i; loop (i+1) + loop !i | i > end = return () + | otherwise = do fn i; loop (i+1) {-# INLINE for_ #-} rep :: Monad m => Int -> (m ()) -> m () diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -5,11 +5,11 @@ -- import Data.Atomics import Data.IORef -import Foreign.Ptr +-- import Foreign.Ptr import GHC.Conc import Control.Concurrent.MVar import Control.Monad -import Control.Exception +-- import Control.Exception import System.Mem.StableName main :: IO () @@ -17,16 +17,16 @@ putStrLn "Run a very simple TLs test" putStrLn $ "pethread_key_t size: "++show PThread.get_pthread_key_size - testIt "GHC" GHC.mkTLS GHC.getTLS GHC.allTLS GHC.freeTLS - testIt "PThread" PThread.mkTLS PThread.getTLS PThread.allTLS PThread.freeTLS + testIt "GHC" GHC.mkTLS GHC.getTLS GHC.allTLS GHC.freeAllTLS + testIt "PThread" PThread.mkTLS PThread.getTLS PThread.allTLS PThread.freeAllTLS testIt :: Show b => String -> (IO (IORef Int) -> IO t) -> (t -> IO (IORef Int)) -> (t -> IO [IORef b]) - -> (t -> IO a) + -> (t -> IO ()) -> IO () -testIt name mkTLS getTLS allTLS freeTLS = do +testIt name mkTLS getTLS allTLS freeAllTLS = do putStrLn$ "\n Testing "++name ++" implementation: " putStrLn "----------------------------------------" numCap <- getNumCapabilities @@ -54,7 +54,7 @@ putStrLn$ "Results: "++show ls2 ls3 <- mapM ssn ls putStrLn$ "Result, stable names: "++show ls3 - freeTLS tls + freeAllTLS tls {- forM_ [1..(10::Int)] $ \_ -> do r <- getTLS tls n <- readIORef r diff --git a/thread-local-storage.cabal b/thread-local-storage.cabal --- a/thread-local-storage.cabal +++ b/thread-local-storage.cabal @@ -1,52 +1,52 @@ --- Initial thread-local-storage.cabal generated by cabal init. For further --- documentation, see http://haskell.org/cabal/users-guide/ - name: thread-local-storage -version: 0.1.0.4 +version: 0.1.1 synopsis: Several options for thread-local-storage (TLS) in Haskell. description: . Thread-local storage, or TLS, is an important ingredient in many algorithms and data structures. - . + . The GHC compiler does not provide a built-in notion of TLS either at the IO-thread or OS thread level. This package provides a few different implementations of a simple TLS API. - . - All exported modules provide exactly the same interface with + . + All exported public modules provide exactly the same interface with different implementations. Run the included criterion benchmark suite to ascertain which performs the best on your platform. - . + . Example criterion benchmark data can be found here (from an Intel Ivy-Bridge i7-3770 desktop): - - + +homepage: https://github.com/rrnewton/thread-local-storage +bug-reports: https://github.com/rrnewton/thread-local-storage/issues license: BSD3 license-file: LICENSE author: Ryan Newton maintainer: rrnewton@gmail.com --- copyright: category: System build-type: Simple --- extra-source-files: cabal-version: >=1.10 -extra-source-files: Data/TLS/TLS_Sig.hs +extra-source-files: CHANGELOG.md, README.md, Data/TLS/TLS_Sig.hs +source-repository head + type: git + location: https://github.com/rrnewton/thread-local-storage + library exposed-modules: Data.TLS.GHC, Data.TLS.PThread -- Not finished yet: -- Data.TLS.GCC - other-modules: Data.TLS.PThread.Internal + Data.TLS.PThread.Internal other-extensions: BangPatterns, NamedFieldPuns, CPP build-depends: base >=4.6 && < 5.0, containers >=0.5 - -- hs-source-dirs: default-language: Haskell2010 - ghc-options: -O2 - c-sources: cbits/helpers.c - + ghc-options: -Wall -O2 + c-sources: cbits/helpers.c + extra-libraries: pthread + benchmark bench-haskell-tls main-is: Main.hs hs-source-dirs: ./bench/ @@ -56,19 +56,15 @@ criterion >= 1.0, atomic-primops >= 0.6.0.6 default-language: Haskell2010 - ghc-options: -rtsopts -O2 -threaded -with-rtsopts=-T - + ghc-options: -Wall -rtsopts -O2 -threaded -with-rtsopts=-T + test-suite test-tls main-is: Main.hs - -- Here we reinclude/rebuild the main sources so we can test the .Internal module: - hs-source-dirs: ./ ./tests/ + hs-source-dirs: tests type: exitcode-stdio-1.0 build-depends: base >= 4.6 && < 5.0, - atomic-primops >= 0.6.0.6 + atomic-primops >= 0.6.0.6, + thread-local-storage default-language: Haskell2010 - ghc-options: -rtsopts -O2 -threaded -with-rtsopts=-N4 - - -- DUPLICATED, from above: - build-depends: containers >=0.5 - c-sources: cbits/helpers.c + ghc-options: -Wall -rtsopts -O2 -threaded -with-rtsopts=-N4