diff options
author | joe <joe@jerkface.net> | 2017-01-26 23:54:32 -0500 |
---|---|---|
committer | joe <joe@jerkface.net> | 2017-01-26 23:54:32 -0500 |
commit | 6a239e20bbc7a84a74721d23587bbf1b8c20c704 (patch) | |
tree | 0cf18f721c2c1cae252f0e40605a9c24c0b9b4b8 /src/Control/Concurrent/Lifted/Instrument.hs | |
parent | b3cebbedeb89fdd6b85c659360241b9251a8f1ae (diff) |
Use -XStrict on thread instrumentation.
Diffstat (limited to 'src/Control/Concurrent/Lifted/Instrument.hs')
-rw-r--r-- | src/Control/Concurrent/Lifted/Instrument.hs | 9 |
1 files changed, 5 insertions, 4 deletions
diff --git a/src/Control/Concurrent/Lifted/Instrument.hs b/src/Control/Concurrent/Lifted/Instrument.hs index 673e77cd..e4582375 100644 --- a/src/Control/Concurrent/Lifted/Instrument.hs +++ b/src/Control/Concurrent/Lifted/Instrument.hs | |||
@@ -1,4 +1,5 @@ | |||
1 | {-# LANGUAGE FlexibleContexts #-} | 1 | {-# LANGUAGE FlexibleContexts #-} |
2 | {-# LANGUAGE Strict #-} | ||
2 | module Control.Concurrent.Lifted.Instrument | 3 | module Control.Concurrent.Lifted.Instrument |
3 | ( module Control.Concurrent.Lifted | 4 | ( module Control.Concurrent.Lifted |
4 | , forkIO | 5 | , forkIO |
@@ -21,13 +22,13 @@ import Data.Time() | |||
21 | import Data.Time.Clock | 22 | import Data.Time.Clock |
22 | 23 | ||
23 | data PerThread = PerThread | 24 | data PerThread = PerThread |
24 | { lbl :: !String | 25 | { lbl :: String |
25 | , startTime :: !UTCTime | 26 | , startTime :: UTCTime |
26 | } | 27 | } |
27 | deriving (Eq,Ord,Show) | 28 | deriving (Eq,Ord,Show) |
28 | 29 | ||
29 | data GlobalState = GlobalState | 30 | data GlobalState = GlobalState |
30 | { threads :: ! ( Map.Map ThreadId PerThread ) | 31 | { threads :: Map.Map ThreadId PerThread |
31 | } | 32 | } |
32 | 33 | ||
33 | globals :: MVar GlobalState | 34 | globals :: MVar GlobalState |
@@ -67,4 +68,4 @@ modifyThreads f = do | |||
67 | g <- takeMVar globals | 68 | g <- takeMVar globals |
68 | let f' st = st { threads = f (threads st) } | 69 | let f' st = st { threads = f (threads st) } |
69 | r = f' g | 70 | r = f' g |
70 | threads r `seq` putMVar globals r | 71 | putMVar globals r |