master..4d894c9 · typeable/thread-local

.gitignoredeleted−3

@@ -1,3 +0,0 @@

1−.stack-work

2−*.~undo-tree~

3−stack.yaml.lock

polysemy-state-tls/LICENSE → LICENSErenamed

The content is the same.

thread-local/example/Main.hs → example/Main.hsrenamed+4−3

@@ -9,8 +9,9 @@ import Control.Monad

99import System.Random

1010

1111main :: IO ()

12−main = do tls <- newThreadLocalWithGC 30

13− replicateConcurrently_ 200000 (f tls)

12+main = do tls <- newThreadLocal

13+ replicateConcurrently_ 200 (f tls)

14+ printThreadLocal tls

1415

1516f :: ThreadLocal Word -> IO ()

1617f tls = do v :: Word <- randomIO

@@ -18,4 +19,4 @@ f tls = do v :: Word <- randomIO

1819 insertThreadLocal v tls

1920 !v' <- fetchThreadLocal tls

2021 unless (Just v == v') $

21− putStrLn ("Ooops! " <> show tid <> " expected " <> show v <> " while the fetched value is " <> show v')

22+ putStrLn ("Ooops! " <> show tid <> " expected " <> show v <> " while the fetched value is " <> show v')

polysemy-state-tls/polysemy-state-tls.cabaldeleted−28

@@ -1,28 +0,0 @@

1−cabal-version: 3.0

2−name: polysemy-state-tls

3−version: 0.1

4−synopsis: Thread local state interpreter for Polysemy

5−-- description:

6−license: MIT

7−license-file: LICENSE

8−author: Nick

9−maintainer: nick@typeable.io

10−-- copyright:

11−category: Control

12−build-type: Simple

13−extra-doc-files: CHANGELOG.md

14−-- extra-source-files:

15−

16−common warnings

17− ghc-options: -Wall

18−

19−library

20− import: warnings

21− exposed-modules: Polysemy.State.TLS

22− -- other-modules:

23− -- other-extensions:

24− build-depends: base >=4.14 && < 5,

25− thread-local,

26− polysemy >= 1.7 && < 1.10

27− hs-source-dirs: src

28− default-language: Haskell2010

polysemy-state-tls/src/Polysemy/State/TLS.hsdeleted−31

@@ -1,31 +0,0 @@

1−{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE FlexibleContexts #-}

3−{-# LANGUAGE GADTs #-}

4−{-# LANGUAGE ScopedTypeVariables #-}

5−{-# LANGUAGE TypeOperators #-}

6−module Polysemy.State.TLS where

7−

8−import Control.Concurrent.ThreadLocal

9−import Data.Maybe (fromMaybe)

10−import Polysemy

11−import Polysemy.State

12−

13−

14−-- | Evaluate the 'State' effect using 'ThreadLocal' semantincs.

15−-- Note that this can only work over state being wrapped in 'Maybe', since the storage for the current thread

16−-- can be empty. For an alternative, see 'runTLStateWithDefault'.

17−runTLState :: forall s r a. Member (Embed IO) r => ThreadLocal s -> Sem (State (Maybe s) ': r) a -> Sem r a

18−runTLState tls = interpret f

19− where f :: forall r' x. State (Maybe s) (Sem r') x -> Sem r x

20− f Get = embed (fetchThreadLocal tls)

21− f (Put (Just v)) = embed (insertThreadLocal v tls)

22− f (Put Nothing) = embed (deleteThreadLocal tls)

23−

24−-- | Evaluate the 'State' effect using 'ThreadLocal' semantincs.

25−-- The default value needs to be provided for cases where the value for the given thread isn't yet set,

26−-- i.e. 'get' is called before 'put'.

27−runTLStateWithDefault :: forall s r a. Member (Embed IO) r => s -> ThreadLocal s -> Sem (State s ': r) a -> Sem r a

28−runTLStateWithDefault def tls = interpret f

29− where f :: forall r' x. State s (Sem r') x -> Sem r x

30− f Get = fromMaybe def <$> embed (fetchThreadLocal tls)

31− f (Put v) = embed (insertThreadLocal v tls)

src/Control/Concurrent/ThreadLocal.hsnew file+10

@@ -0,0 +1,10 @@

1+module Control.Concurrent.ThreadLocal ( ThreadLocal -- exported opaque

2+ , newThreadLocal

3+ , insertThreadLocal

4+ , fetchThreadLocal

5+ , gcThreadLocal

6+ , dumpThreadLocal

7+ , printThreadLocal

8+ ) where

9+

10+import Control.Concurrent.ThreadLocal.Internal

src/Control/Concurrent/ThreadLocal/Internal.hsnew file+62

@@ -0,0 +1,62 @@

1+{-# LANGUAGE TupleSections #-}

2+module Control.Concurrent.ThreadLocal.Internal where

3+

4+import Control.Concurrent (ThreadId, myThreadId, mkWeakThreadId)

5+import Control.Concurrent.MVar

6+import Control.Monad ((<=<), guard)

7+import Data.Foldable (toList)

8+import Data.Maybe (isJust)

9+import Data.Vector (Vector)

10+import qualified Data.Vector as Vector

11+import Data.Witherable

12+import System.Mem.Weak

13+

14+data LocalValue a = LocalValue {-# UNPACK #-} !(Weak ThreadId) -- ^ ThreadId reference used as a key

15+ String -- ^ String representation of ThreadId, for debugging

16+ a

17+

18+localThread :: LocalValue a -> IO (Maybe ThreadId)

19+localThread (LocalValue weak _ _) = deRefWeak weak

20+

21+derefLocal :: LocalValue a -> IO (Maybe (ThreadId, a))

22+derefLocal (LocalValue weak _ a) = fmap (,a) <$> deRefWeak weak

23+

24+makeLocal :: ThreadId -> a -> IO (LocalValue a)

25+makeLocal tid a = do weak <- mkWeakThreadId tid

26+ pure (LocalValue weak (show tid) a)

27+

28+newtype ThreadLocal a = ThreadLocal { values :: MVar (Vector (LocalValue a))

29+ }

30+

31+-- | Create a new thread local storage of type 'a'

32+newThreadLocal :: IO (ThreadLocal a)

33+newThreadLocal = do var <- newMVar Vector.empty

34+ return (ThreadLocal var)

35+

36+-- | Insert a value for the current thread

37+insertThreadLocal :: a -> ThreadLocal a -> IO ()

38+insertThreadLocal val (ThreadLocal var) = do tid <- myThreadId

39+ loc <- makeLocal tid val

40+ modifyMVar_ var $ \v ->

41+ do ts <- filterA (\l -> do tid' <- localThread l

42+ pure (isJust tid' && Just tid /= tid')

43+ ) (toList v)

44+ pure (Vector.fromList (loc:ts))

45+

46+-- | Fetch a value for the current thread. If none was inserted previously, return Nothing.

47+fetchThreadLocal :: ThreadLocal a -> IO (Maybe a)

48+fetchThreadLocal (ThreadLocal var) = do tid <- myThreadId

49+ v <- readMVar var

50+ f tid <$> wither derefLocal v

51+ where f tid vec = do ((tid',v),_) <- Vector.uncons vec

52+ guard (tid == tid')

53+ pure v

54+

55+gcThreadLocal :: ThreadLocal a -> IO ()

56+gcThreadLocal (ThreadLocal var) = modifyMVar_ var (filterA (fmap isJust . localThread))

57+

58+dumpThreadLocal :: ThreadLocal a -> IO [(Maybe ThreadId, String, a)]

59+dumpThreadLocal (ThreadLocal var) = traverse (\l@(LocalValue _ s v) -> (,s,v) <$> localThread l) . toList =<< readMVar var

60+

61+printThreadLocal :: Show a => ThreadLocal a -> IO ()

62+printThreadLocal = print <=< dumpThreadLocal

src/Control/Concurrent/ThreadLocal/Unsafe.hsnew file+9

@@ -0,0 +1,9 @@

1+module Control.Concurrent.ThreadLocal.Unsafe where

2+

3+--import Control.Concurrent.ThreadLocal.Internal

4+--import Data.Map (Map)

5+--import qualified Data.Map (Map)

6+

7+

8+--dumpThreadLocal :: ThreadLocal a -> IO (Map ThreadId a)

9+--dumpThreadLocal (ThreadLocal ref) = do m <-

stack.yaml+65−3

@@ -1,5 +1,67 @@

1−resolver: lts-21.1

1+# This file was automatically generated by 'stack init'

2+#

3+# Some commonly used options have been documented as comments in this file.

4+# For advanced use and comprehensive documentation of the format, please see:

5+# https://docs.haskellstack.org/en/stable/yaml_configuration/

26

7+# Resolver to choose a 'specific' stackage snapshot or a compiler version.

8+# A snapshot resolver dictates the compiler version and the set of packages

9+# to be used for project dependencies. For example:

10+#

11+# resolver: lts-3.5

12+# resolver: nightly-2015-09-21

13+# resolver: ghc-7.10.2

14+#

15+# The location of a snapshot can be provided as a file or url. Stack assumes

16+# a snapshot provided as a file might change, whereas a url resource does not.

17+#

18+# resolver: ./custom-snapshot.yaml

19+# resolver: https://example.com/snapshots/2018-01-01.yaml

20+resolver:

21+ url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/1.yaml

22+

23+# User packages to be built.

24+# Various formats can be used as shown in the example below.

25+#

26+# packages:

27+# - some-directory

28+# - https://example.com/foo/bar/baz-0.0.2.tar.gz

29+# subdirs:

30+# - auto-update

31+# - wai

332packages:

4−- thread-local

5−- polysemy-state-tls

33+- .

34+# Dependency packages to be pulled from upstream that are not in the resolver.

35+# These entries can reference officially published versions as well as

36+# forks / in-progress versions pinned to a git hash. For example:

37+#

38+# extra-deps:

39+# - acme-missiles-0.3

40+# - git: https://github.com/commercialhaskell/stack.git

41+# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a

42+#

43+# extra-deps: []

44+

45+# Override default flag values for local packages and extra-deps

46+# flags: {}

47+

48+# Extra package databases containing global packages

49+# extra-package-dbs: []

50+

51+# Control whether we use the GHC we find on the path

52+# system-ghc: true

53+#

54+# Require a specific version of stack, using version ranges

55+# require-stack-version: -any # Default

56+# require-stack-version: ">=2.9"

57+#

58+# Override the architecture used by stack, especially useful on Windows

59+# arch: i386

60+# arch: x86_64

61+#

62+# Extra directories used by stack for building

63+# extra-include-dirs: [/path/to/dir]

64+# extra-lib-dirs: [/path/to/dir]

65+#

66+# Allow a newer minor version of GHC than the snapshot specifies

67+# compiler-check: newer-minor

thread-local/thread-local.cabal → thread-local.cabalrenamed+3−4

@@ -18,11 +18,10 @@ common warnings

1818library

1919 import: warnings

2020 exposed-modules: Control.Concurrent.ThreadLocal

21− other-modules: Control.Concurrent.ThreadLocal.GC

22− Control.Concurrent.ThreadLocal.Internal

21+ Control.Concurrent.ThreadLocal.Unsafe

22+ other-modules: Control.Concurrent.ThreadLocal.Internal

2323 build-depends: base >=4.16 && < 5,

24− async >= 2.2,

25− containers >= 0.6,

24+ vector >= 0.13,

2625 witherable

2726 hs-source-dirs: src

2827 default-language: Haskell2010

thread-local/LICENSEdeleted−20

@@ -1,20 +0,0 @@

2−

3−Permission is hereby granted, free of charge, to any person obtaining

4−a copy of this software and associated documentation files (the

5−"Software"), to deal in the Software without restriction, including

6−without limitation the rights to use, copy, modify, merge, publish,

7−distribute, sublicense, and/or sell copies of the Software, and to

8−permit persons to whom the Software is furnished to do so, subject to

9−the following conditions:

10−

11−The above copyright notice and this permission notice shall be included

12−in all copies or substantial portions of the Software.

13−

14−THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,

15−EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF

16−MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.

17−IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY

18−CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,

19−TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE

20−SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

thread-local/src/Control/Concurrent/ThreadLocal.hsdeleted−17

@@ -1,17 +0,0 @@

1−module Control.Concurrent.ThreadLocal ( ThreadLocal -- exported opaque

2− , newThreadLocal

3− , newThreadLocalWithGC

4− , insertThreadLocal

5− , fetchThreadLocal

6− , deleteThreadLocal

7− ) where

8−

9−import Control.Concurrent.ThreadLocal.Internal

10−import Control.Concurrent.ThreadLocal.GC

11−

12−-- | The version of 'newThreadLocal' that also launches a separate GC thread.

13−-- Takes the interval for GC in seconds. GC thread dies automatically once

14−-- 'ThreadLocal' is collected.

15−newThreadLocalWithGC :: Word -> IO (ThreadLocal a)

16−newThreadLocalWithGC interval = do tls <- newThreadLocal

17− addGC tls interval

thread-local/src/Control/Concurrent/ThreadLocal/GC.hsdeleted−46

@@ -1,46 +0,0 @@

1−module Control.Concurrent.ThreadLocal.GC where

2−

3−import Control.Concurrent.ThreadLocal.Internal

4−

5−import Control.Concurrent.Async

6−import Control.Concurrent.MVar

7−import Data.Either

8−import qualified Data.Map as Map

9−import GHC.Conc

10−import System.Mem.Weak

11−

12−-- | Check whether a thread is still alive.

13−isThreadAlive :: ThreadId -> IO Bool

14−isThreadAlive tid = isAlive <$> threadStatus tid

15− where isAlive ThreadRunning = True

16− isAlive (ThreadBlocked _) = True

17− isAlive _ = False

18−

19−-- | Sort alive from dead

20−splitAlive :: [ThreadId] -> IO ([ThreadId], [ThreadId])

21−splitAlive = fmap partitionEithers

22− . traverse (\t -> s t <$> isThreadAlive t)

23− where s x b = if b then Left x else Right x

24−

25−collectGarbage :: ThreadMap a -> IO (ThreadMap a)

26−collectGarbage m = do (_live, dead) <- splitAlive (Map.keys m)

27− pure (foldr Map.delete m dead)

28−

29−gcLoop :: Weak (MVar (ThreadMap a)) -> Word -> IO ()

30−gcLoop wvar t = do threadDelay (fromIntegral t * 1000000)

31− var' <- deRefWeak wvar

32− whenJust var' $ \var ->

33− do modifyMVar_ var collectGarbage

34− gcLoop wvar t

35−

36−whenJust :: Monad m => Maybe a -> (a -> m ()) -> m ()

37−whenJust (Just v) f = f v

38−whenJust Nothing _ = pure ()

39−{-# INLINE whenJust #-}

40−

41−addGC :: ThreadLocal a -> Word -> IO (ThreadLocal a)

42−addGC (ThreadLocal var _) interval =

43− do wvar <- mkWeakMVar var (pure ())

44− a <- async (gcLoop wvar interval)

45− labelThread (asyncThreadId a) "ThreadLocal GC Loop"

46− pure (ThreadLocal var (Just a))

thread-local/src/Control/Concurrent/ThreadLocal/Internal.hsdeleted−39

@@ -1,39 +0,0 @@

1−module Control.Concurrent.ThreadLocal.Internal where

2−

3−import Control.Concurrent (ThreadId, myThreadId)

4−import Control.Concurrent.Async

5−import Control.Concurrent.MVar

6−import Data.Map (Map)

7−import qualified Data.Map.Strict as Map

8−

9−type ThreadMap a = Map ThreadId a

10−

11−data ThreadLocal a = ThreadLocal { mvar :: MVar (ThreadMap a)

12− , gcThread :: Maybe (Async ())

13− }

14−

15−-- | Create a new thread local storage of type 'a'

16−-- Note that TLS created by this function will accumulate dead threads

17−-- and thus leak memory during its lifetime. This is mostly fine for shorter-living

18−-- instances. If you plan on having this 'ThreadLocal' live longer than a while,

19−-- consider using 'newThreadLocalWithGC' instead.

20−newThreadLocal :: IO (ThreadLocal a)

21−newThreadLocal = do var <- newMVar Map.empty

22− return (ThreadLocal var Nothing)

23−

24−-- | Insert a value for the current thread

25−insertThreadLocal :: a -> ThreadLocal a -> IO ()

26−insertThreadLocal val (ThreadLocal var _) = do tid <- myThreadId

27− modifyMVar_ var (pure . Map.insert tid val)

28−

29−-- | Fetch a value for the current thread. If none was inserted previously, return Nothing.

30−fetchThreadLocal :: ThreadLocal a -> IO (Maybe a)

31−fetchThreadLocal (ThreadLocal var _) = do tid <- myThreadId

32− m <- readMVar var

33− return (Map.lookup tid m)

34−

35−-- | Delete a currently held value for this thread.

36−deleteThreadLocal :: ThreadLocal a -> IO ()

37−deleteThreadLocal (ThreadLocal var _) = do tid <- myThreadId

38− modifyMVar_ var (pure . Map.delete tid)

39−