thread-local-storage (empty) → 0.1.0.0
raw patch · 9 files changed
+506/−0 lines, 9 filesdep +atomic-primopsdep +basedep +containerssetup-changed
Dependencies added: atomic-primops, base, containers, criterion, thread-local-storage
Files
- Data/TLS/GHC.hs +58/−0
- Data/TLS/PThread.hs +20/−0
- Data/TLS/PThread/Internal.hs +100/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- bench/Main.hs +136/−0
- cbits/helpers.c +18/−0
- tests/Main.hs +70/−0
- thread-local-storage.cabal +72/−0
+ Data/TLS/GHC.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE CPP #-}++-- | This is the simplest implementation of thread-local storage using+-- GHC's built-in ThreadId capabilities.++module Data.TLS.GHC+ ( TLS+ , mkTLS+ , getTLS+ , allTLS+ , forEachTLS_+ , freeTLS+ ) where++import Control.Monad+import Control.Exception (evaluate)+import Control.Concurrent+import Data.Map.Strict as M+import Data.IORef++-- Module signature:+--------------------------------------------------------------------------------++#include "TLS_Sig.hs"++--------------------------------------------------------------------------------++-- | A thread-local variable of type `a`.+data TLS a = TLS { mkNew :: !(IO a)+ , allCopies :: {-# UNPACK #-} !(IORef (Map ThreadId a)) }++mkTLS new = do+ v <- newIORef $! M.empty+ return $! TLS new v++getTLS TLS{mkNew,allCopies} = do+ tid <- myThreadId+ peek <- readIORef allCopies+ case M.lookup tid peek of+ Just a -> return a+ Nothing -> do+ a <- mkNew+ atomicModifyIORef' allCopies (\ mp -> (M.insert tid a mp, ()))+ return $! a++allTLS TLS{allCopies} = do+ mp <- readIORef allCopies+ return $! M.elems mp++forEachTLS_ tls fn = do+ ls <- allTLS tls+ forM_ ls fn ++-- Nothing to do here... we haven't pinned anything. Normal GC is fine.+freeTLS _ = return ()+
+ Data/TLS/PThread.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ForeignFunctionInterface #-}++-- | An implementation of TLS using the standard, Posix+-- `pthread_create_key` routine.++module Data.TLS.PThread+ ( TLS+ , mkTLS+ , getTLS+ , allTLS+ , forEachTLS_+ , freeTLS+ )+ where++-- Same as the internal module but with limited export:+import Data.TLS.PThread.Internal
+ Data/TLS/PThread/Internal.hs view
@@ -0,0 +1,100 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ForeignFunctionInterface #-}++-- Export EVERYTHING from this internal module.+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))+ +#include "../TLS_Sig.hs"+--------------------------------------------------------------------------------++type Key = Word++foreign import ccall unsafe+ get_pthread_key_size :: Int++foreign import ccall unsafe+ pthread_key_create :: Ptr Key -> Ptr () -> IO Int++foreign import ccall unsafe+ easy_make_pthread_key :: IO Key+ +foreign import ccall unsafe+ pthread_getspecific :: Key -> IO (StablePtr a)++foreign import ccall unsafe+ pthread_setspecific :: Key -> StablePtr a -> IO Int++foreign import ccall unsafe+ pthread_key_delete :: Key -> IO Int+ +check_error :: ()+check_error =+-- if get_pthread_key_size == sizeOf(0::Word)+ if get_pthread_key_size <= sizeOf(0::Word)+ 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 + unless (code == 0) (error $ "pthread_setspecific returned error code: "++show code)++{-# INLINE delete #-}+delete :: Key -> IO ()+delete k = do+ code <- pthread_key_delete k+-- 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+-- putStrLn $ "KEY CREATED: "++show key+ allC <- newIORef []+ return $! TLS key new allC++getTLS TLS{key,mknew,allCopies} = do+ p <- pthread_getspecific key+ if castStablePtrToPtr p == nullPtr then do+ a <- mknew+ sp <- newStablePtr a+ setspecific key sp+ atomicModifyIORef' allCopies (\l -> (sp:l,()))+ return a+ else+ deRefStablePtr p++allTLS TLS{allCopies} = do + ls <- readIORef allCopies+ mapM deRefStablePtr ls++forEachTLS_ tls fn = do+ ls <- allTLS tls+ forM_ ls fn ++freeTLS TLS{key,allCopies} = do + ls <- readIORef allCopies+ delete key+ mapM_ freeStablePtr ls
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2014, Ryan Newton++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * 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.++ * Neither the name of Ryan Newton nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"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 COPYRIGHT+OWNER 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ bench/Main.hs view
@@ -0,0 +1,136 @@+{-# LANGUAGE BangPatterns #-}++module Main where++import qualified Data.TLS.GHC as GHC+import qualified Data.TLS.GCC as GCC+import qualified Data.TLS.PThread as PT++import Criterion+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 +--------------------------------------------------------------------------------+ +main :: IO ()+main = do+ numProc <- getNumProcessors+ n <- getNumCapabilities + when (n == 1) $ do putStrLn "HACK: using setNumCapabilities to bump it up... should set this in the .cabal"+ setNumCapabilities numProc+ numCap <- getNumCapabilities+ putStrLn $ "Benchmarking platform with "++show numProc+++ " processors, while currently using "++show numCap++" threads."++ -- Substitute in default command line args:+ args <- getArgs+ let args' = if null args+ 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 " + else args++ threadify fn =+ bgroup ""+ [ fn (threads, suff)+ | threads <- [1..numCap*4],+ let suff = "_" ++ show threads ++"io_"++ show numCap++"os" ]++ mkTests name mkTLS getTLS freeTLS = bgroup name + [+ -- bench ("counter/getTLS/incrCntr"++suff) $+ -- benchPar0 threads (GHC.mkTLS (newCounter 0))+ -- (\t -> incrCounter_ 1 =<< GHC.getTLS t)+ threadify $ \ (threads,suff) -> + bench ("counter/getTLS/readIORef"++suff) $+ benchPar0 threads (mkTLS (newIORef ()))+ (\t -> readIORef =<< getTLS t)+ freeTLS+ ]+ + withArgs args' $ defaultMain $ + [ mkTests "PThread" PT.mkTLS PT.getTLS PT.freeTLS+ , mkTests "GHC" GHC.mkTLS GHC.getTLS GHC.freeTLS+ ]+{- bgroup "infrastructure"+ [ bench ("benchPar1"++suff) $ benchPar1 threads (return ())+ , bench ("benchPar0"++suff) $ benchPar0 threads (return ()) (\_ -> return ())+-- , bench ("benchPar2"++suff) $ benchPar2 threads (return ()) + ], -} ++ -- | ]++ where++ ++----------------------------------------------------------------------------------------------------++benchPar0 :: Int -> IO a -> (a -> IO ()) -> (a -> IO ()) -> Benchmarkable+benchPar0 numT new fn shutd = Benchmarkable $ \ iters -> do+ x <- new+ numCap <- getNumCapabilities+ -- We compute the number of iterations such that the time would be+ -- flat IFF parallelism works perfectly up to numCapabilities, and+ -- then load balancing works perfectly when # threads exceeds+ -- numCapabilities.+ let totalIters = (fromIntegral iters) * (max numCap numT)+ perThread = totalIters `quot` numT+ mvs <- forM [0..numT-1] $ \ n -> do+ v <- newEmptyMVar + _ <- forkOn n $ do rep perThread (fn x)+ putMVar v ()+ return v+ forM_ mvs takeMVar+ -- Shut down only when all threads are finished with it:+ shutd x+{-# INLINE benchPar0 #-}+++-- | Benchmarking the same action on ALL of N threads.+-- This version uses MVar synchronization.+benchPar1 :: Int -> IO () -> Benchmarkable+benchPar1 num act = Benchmarkable $ \ iters -> do + mvs <- forM [0..num-1] $ \ n -> do+ v <- newEmptyMVar + _ <- forkOn n $ do rep (fromIntegral iters) act+ putMVar v ()+ return v+ forM_ mvs takeMVar +{-# INLINE benchPar1 #-}++-- | This version never blocks on an MVar.+benchPar2 :: Int -> IO () -> Benchmarkable+benchPar2 num act = Benchmarkable $ \ iters -> do+ done <- newCounter 0+ let waitCounter = do x <- readCounter done+ unless (num == x) waitCounter+ go = do rep (fromIntegral iters) act+ incrCounter_ 1 done+ waitCounter+ forM_ [1..num-1] $ \ n -> forkOn n go+ go+ +{-# INLINE benchPar2 #-}++-- | My own forM for inclusive numeric ranges (not requiring deforestation optimizations).+for_ :: Monad m => Int -> Int -> (Int -> m ()) -> m ()+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)+{-# INLINE for_ #-}++rep :: Monad m => Int -> (m ()) -> m ()+rep n m = for_ 1 n (\_ -> m)+{-# INLINE rep #-}+
+ cbits/helpers.c view
@@ -0,0 +1,18 @@++#include <pthread.h>+#include <stdio.h>+#include <stdlib.h>++long get_pthread_key_size() {+ return sizeof(pthread_key_t);+}++pthread_key_t easy_make_pthread_key() {+ pthread_key_t key;+ int rc = pthread_key_create(&key, NULL);+ if (rc) {+ fprintf(stderr, "pthread_key_create returned error code: %d\n", rc);+ abort();+ }+ return key; +}
+ tests/Main.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE BangPatterns #-}++import qualified Data.TLS.PThread.Internal as PThread+import qualified Data.TLS.GHC as GHC++-- import Data.Atomics+import Data.IORef+import Foreign.Ptr+import GHC.Conc+import Control.Concurrent.MVar+import Control.Monad+import Control.Exception+import System.Mem.StableName++main :: IO ()+main = do+ 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 :: Show b => String+ -> (IO (IORef Int) -> IO t)+ -> (t -> IO (IORef Int))+ -> (t -> IO [IORef b])+ -> (t -> IO a)+ -> IO ()+testIt name mkTLS getTLS allTLS freeTLS = do+ putStrLn$ "\n Testing "++name ++" implementation: "+ putStrLn "----------------------------------------"+ numCap <- getNumCapabilities+ tls <- mkTLS (do putStrLn " New() called.."+ newIORef (-1 :: Int))+ mvs <- sequence $ replicate numCap newEmptyMVar+ forM_ (zip [0..] mvs) $ \(ix,mv) -> forkOn ix $ do+ r <- getTLS tls+ n <- readIORef r+ tid <- myThreadId+ sn <- ssn r+ -- forM_ [1..100] $ \_ -> do writeIORef r ix; writeBarrier+ putStrLn$ "Thread "++show ix++" / "++show tid++" read "++show n++", stable name "++ sn+ writeIORef r ix+ putMVar mv ()+ forM_ mvs takeMVar -- Join+ do r <- getTLS tls+ n <- readIORef r+ tid <- myThreadId+ sn <- ssn r + putStrLn$ "Main thread ("++show tid++") read "++show n++", stable name "++ sn+ ls <- allTLS tls+ putStrLn$ "Reading all thread-local versions, got "++show (length ls)+ ls2 <- mapM readIORef ls+ putStrLn$ "Results: "++show ls2+ ls3 <- mapM ssn ls+ putStrLn$ "Result, stable names: "++show ls3+ freeTLS tls+ {- forM_ [1..(10::Int)] $ \_ -> do + r <- getTLS tls+ n <- readIORef r+ tid <- myThreadId+ sn <- ssn r+ putStrLn$ "Read/write redux ("++show tid++"): "++show n++", stable name "++ sn+ writeIORef r 99 -}+ putStrLn "TLS Freed."+++ssn :: a -> IO String+ssn a = do n <- makeStableName a+ return $ show (hashStableName n)
+ thread-local-storage.cabal view
@@ -0,0 +1,72 @@+-- 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.0+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+ 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):+ <http://www.cs.indiana.edu/~rrnewton/datasets/xmen_tls_report.html>+ + +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++library+ exposed-modules: Data.TLS.GHC, Data.TLS.PThread+-- Data.TLS.GCC, + other-modules: Data.TLS.PThread.Internal+ other-extensions: BangPatterns, NamedFieldPuns, CPP+ c-sources: cbits/helpers.c+ build-depends: base >=4.6 && < 5.0,+ containers >=0.5+ -- hs-source-dirs: + default-language: Haskell2010+ ghc-options: -O2+ + +benchmark bench-haskell-tls+ main-is: Main.hs+ hs-source-dirs: ./bench/+ type: exitcode-stdio-1.0+ build-depends: thread-local-storage+ build-depends: base >= 4.6 && < 5.0,+ criterion >= 1.0,+ atomic-primops >= 0.6.0.6+ default-language: Haskell2010+ ghc-options: -rtsopts -O2 -threaded -with-rtsopts=-T + ++test-suite test-tls+ main-is: Main.hs+ hs-source-dirs: ./ ./tests/+ type: exitcode-stdio-1.0+-- build-depends: thread-local-storage+ build-depends: base >= 4.6 && < 5.0,+ atomic-primops >= 0.6.0.6+ default-language: Haskell2010+ ghc-options: -rtsopts -O2 -threaded -with-rtsopts=-N4++ -- DUPLICATED, from above:+ build-depends: containers >=0.5+ c-sources: cbits/helpers.c +