Improve accuracy of get/setAllocationCounter
[ghc.git] / libraries / base / GHC / Conc / Sync.hs
1 {-# LANGUAGE Unsafe #-}
2 {-# LANGUAGE CPP
3 , NoImplicitPrelude
4 , BangPatterns
5 , MagicHash
6 , UnboxedTuples
7 , UnliftedFFITypes
8 , StandaloneDeriving
9 , RankNTypes
10 #-}
11 {-# OPTIONS_GHC -Wno-missing-signatures #-}
12 {-# OPTIONS_HADDOCK not-home #-}
13
14 -----------------------------------------------------------------------------
15 -- |
16 -- Module : GHC.Conc.Sync
17 -- Copyright : (c) The University of Glasgow, 1994-2002
18 -- License : see libraries/base/LICENSE
19 --
20 -- Maintainer : cvs-ghc@haskell.org
21 -- Stability : internal
22 -- Portability : non-portable (GHC extensions)
23 --
24 -- Basic concurrency stuff.
25 --
26 -----------------------------------------------------------------------------
27
28 -- No: #hide, because bits of this module are exposed by the stm package.
29 -- However, we don't want this module to be the home location for the
30 -- bits it exports, we'd rather have Control.Concurrent and the other
31 -- higher level modules be the home. Hence:
32
33 -- #not-home
34 module GHC.Conc.Sync
35 ( ThreadId(..)
36
37 -- * Forking and suchlike
38 , forkIO
39 , forkIOWithUnmask
40 , forkOn
41 , forkOnWithUnmask
42 , numCapabilities
43 , getNumCapabilities
44 , setNumCapabilities
45 , getNumProcessors
46 , numSparks
47 , childHandler
48 , myThreadId
49 , killThread
50 , throwTo
51 , par
52 , pseq
53 , runSparks
54 , yield
55 , labelThread
56 , mkWeakThreadId
57
58 , ThreadStatus(..), BlockReason(..)
59 , threadStatus
60 , threadCapability
61
62 , newStablePtrPrimMVar, PrimMVar
63
64 -- * Allocation counter and quota
65 , setAllocationCounter
66 , getAllocationCounter
67 , enableAllocationLimit
68 , disableAllocationLimit
69
70 -- * TVars
71 , STM(..)
72 , atomically
73 , retry
74 , orElse
75 , throwSTM
76 , catchSTM
77 , alwaysSucceeds
78 , always
79 , TVar(..)
80 , newTVar
81 , newTVarIO
82 , readTVar
83 , readTVarIO
84 , writeTVar
85 , unsafeIOToSTM
86
87 -- * Miscellaneous
88 , withMVar
89 , modifyMVar_
90
91 , setUncaughtExceptionHandler
92 , getUncaughtExceptionHandler
93
94 , reportError, reportStackOverflow, reportHeapOverflow
95
96 , sharedCAF
97 ) where
98
99 import Foreign
100 import Foreign.C
101
102 import Data.Typeable
103 import Data.Maybe
104
105 import GHC.Base
106 import {-# SOURCE #-} GHC.IO.Handle ( hFlush )
107 import {-# SOURCE #-} GHC.IO.Handle.FD ( stdout )
108 import GHC.Int
109 import GHC.IO
110 import GHC.IO.Encoding.UTF8
111 import GHC.IO.Exception
112 import GHC.Exception
113 import qualified GHC.Foreign
114 import GHC.IORef
115 import GHC.MVar
116 import GHC.Ptr
117 import GHC.Real ( fromIntegral )
118 import GHC.Show ( Show(..), showString )
119 import GHC.Stable ( StablePtr(..) )
120 import GHC.Weak
121
122 infixr 0 `par`, `pseq`
123
124 -----------------------------------------------------------------------------
125 -- 'ThreadId', 'par', and 'fork'
126 -----------------------------------------------------------------------------
127
128 data ThreadId = ThreadId ThreadId#
129 -- ToDo: data ThreadId = ThreadId (Weak ThreadId#)
130 -- But since ThreadId# is unlifted, the Weak type must use open
131 -- type variables.
132 {- ^
133 A 'ThreadId' is an abstract type representing a handle to a thread.
134 'ThreadId' is an instance of 'Eq', 'Ord' and 'Show', where
135 the 'Ord' instance implements an arbitrary total ordering over
136 'ThreadId's. The 'Show' instance lets you convert an arbitrary-valued
137 'ThreadId' to string form; showing a 'ThreadId' value is occasionally
138 useful when debugging or diagnosing the behaviour of a concurrent
139 program.
140
141 /Note/: in GHC, if you have a 'ThreadId', you essentially have
142 a pointer to the thread itself. This means the thread itself can\'t be
143 garbage collected until you drop the 'ThreadId'.
144 This misfeature will hopefully be corrected at a later date.
145
146 -}
147
148 -- | @since 4.2.0.0
149 instance Show ThreadId where
150 showsPrec d t =
151 showString "ThreadId " .
152 showsPrec d (getThreadId (id2TSO t))
153
154 foreign import ccall unsafe "rts_getThreadId" getThreadId :: ThreadId# -> CInt
155
156 id2TSO :: ThreadId -> ThreadId#
157 id2TSO (ThreadId t) = t
158
159 foreign import ccall unsafe "cmp_thread" cmp_thread :: ThreadId# -> ThreadId# -> CInt
160 -- Returns -1, 0, 1
161
162 cmpThread :: ThreadId -> ThreadId -> Ordering
163 cmpThread t1 t2 =
164 case cmp_thread (id2TSO t1) (id2TSO t2) of
165 -1 -> LT
166 0 -> EQ
167 _ -> GT -- must be 1
168
169 -- | @since 4.2.0.0
170 instance Eq ThreadId where
171 t1 == t2 =
172 case t1 `cmpThread` t2 of
173 EQ -> True
174 _ -> False
175
176 -- | @since 4.2.0.0
177 instance Ord ThreadId where
178 compare = cmpThread
179
180 -- | Every thread has an allocation counter that tracks how much
181 -- memory has been allocated by the thread. The counter is
182 -- initialized to zero, and 'setAllocationCounter' sets the current
183 -- value. The allocation counter counts *down*, so in the absence of
184 -- a call to 'setAllocationCounter' its value is the negation of the
185 -- number of bytes of memory allocated by the thread.
186 --
187 -- There are two things that you can do with this counter:
188 --
189 -- * Use it as a simple profiling mechanism, with
190 -- 'getAllocationCounter'.
191 --
192 -- * Use it as a resource limit. See 'enableAllocationLimit'.
193 --
194 -- Allocation accounting is accurate only to about 4Kbytes.
195 --
196 -- @since 4.8.0.0
197 setAllocationCounter :: Int64 -> IO ()
198 setAllocationCounter (I64# i) = IO $ \s ->
199 case setThreadAllocationCounter# i s of s' -> (# s', () #)
200
201 -- | Return the current value of the allocation counter for the
202 -- current thread.
203 --
204 -- @since 4.8.0.0
205 getAllocationCounter :: IO Int64
206 getAllocationCounter = IO $ \s ->
207 case getThreadAllocationCounter# s of (# s', ctr #) -> (# s', I64# ctr #)
208
209 -- | Enables the allocation counter to be treated as a limit for the
210 -- current thread. When the allocation limit is enabled, if the
211 -- allocation counter counts down below zero, the thread will be sent
212 -- the 'AllocationLimitExceeded' asynchronous exception. When this
213 -- happens, the counter is reinitialised (by default
214 -- to 100K, but tunable with the @+RTS -xq@ option) so that it can handle
215 -- the exception and perform any necessary clean up. If it exhausts
216 -- this additional allowance, another 'AllocationLimitExceeded' exception
217 -- is sent, and so forth. Like other asynchronous exceptions, the
218 -- 'AllocationLimitExceeded' exception is deferred while the thread is inside
219 -- 'mask' or an exception handler in 'catch'.
220 --
221 -- Note that memory allocation is unrelated to /live memory/, also
222 -- known as /heap residency/. A thread can allocate a large amount of
223 -- memory and retain anything between none and all of it. It is
224 -- better to think of the allocation limit as a limit on
225 -- /CPU time/, rather than a limit on memory.
226 --
227 -- Compared to using timeouts, allocation limits don't count time
228 -- spent blocked or in foreign calls.
229 --
230 -- @since 4.8.0.0
231 enableAllocationLimit :: IO ()
232 enableAllocationLimit = do
233 ThreadId t <- myThreadId
234 rts_enableThreadAllocationLimit t
235
236 -- | Disable allocation limit processing for the current thread.
237 --
238 -- @since 4.8.0.0
239 disableAllocationLimit :: IO ()
240 disableAllocationLimit = do
241 ThreadId t <- myThreadId
242 rts_disableThreadAllocationLimit t
243
244 foreign import ccall unsafe "rts_enableThreadAllocationLimit"
245 rts_enableThreadAllocationLimit :: ThreadId# -> IO ()
246
247 foreign import ccall unsafe "rts_disableThreadAllocationLimit"
248 rts_disableThreadAllocationLimit :: ThreadId# -> IO ()
249
250 {- |
251 Creates a new thread to run the 'IO' computation passed as the
252 first argument, and returns the 'ThreadId' of the newly created
253 thread.
254
255 The new thread will be a lightweight, /unbound/ thread. Foreign calls
256 made by this thread are not guaranteed to be made by any particular OS
257 thread; if you need foreign calls to be made by a particular OS
258 thread, then use 'Control.Concurrent.forkOS' instead.
259
260 The new thread inherits the /masked/ state of the parent (see
261 'Control.Exception.mask').
262
263 The newly created thread has an exception handler that discards the
264 exceptions 'BlockedIndefinitelyOnMVar', 'BlockedIndefinitelyOnSTM', and
265 'ThreadKilled', and passes all other exceptions to the uncaught
266 exception handler.
267 -}
268 forkIO :: IO () -> IO ThreadId
269 forkIO action = IO $ \ s ->
270 case (fork# action_plus s) of (# s1, tid #) -> (# s1, ThreadId tid #)
271 where
272 -- We must use 'catch' rather than 'catchException' because the action
273 -- could be bottom. #13330
274 action_plus = catch action childHandler
275
276 -- | Like 'forkIO', but the child thread is passed a function that can
277 -- be used to unmask asynchronous exceptions. This function is
278 -- typically used in the following way
279 --
280 -- > ... mask_ $ forkIOWithUnmask $ \unmask ->
281 -- > catch (unmask ...) handler
282 --
283 -- so that the exception handler in the child thread is established
284 -- with asynchronous exceptions masked, meanwhile the main body of
285 -- the child thread is executed in the unmasked state.
286 --
287 -- Note that the unmask function passed to the child thread should
288 -- only be used in that thread; the behaviour is undefined if it is
289 -- invoked in a different thread.
290 --
291 -- @since 4.4.0.0
292 forkIOWithUnmask :: ((forall a . IO a -> IO a) -> IO ()) -> IO ThreadId
293 forkIOWithUnmask io = forkIO (io unsafeUnmask)
294
295 {- |
296 Like 'forkIO', but lets you specify on which capability the thread
297 should run. Unlike a `forkIO` thread, a thread created by `forkOn`
298 will stay on the same capability for its entire lifetime (`forkIO`
299 threads can migrate between capabilities according to the scheduling
300 policy). `forkOn` is useful for overriding the scheduling policy when
301 you know in advance how best to distribute the threads.
302
303 The `Int` argument specifies a /capability number/ (see
304 'getNumCapabilities'). Typically capabilities correspond to physical
305 processors, but the exact behaviour is implementation-dependent. The
306 value passed to 'forkOn' is interpreted modulo the total number of
307 capabilities as returned by 'getNumCapabilities'.
308
309 GHC note: the number of capabilities is specified by the @+RTS -N@
310 option when the program is started. Capabilities can be fixed to
311 actual processor cores with @+RTS -qa@ if the underlying operating
312 system supports that, although in practice this is usually unnecessary
313 (and may actually degrade performance in some cases - experimentation
314 is recommended).
315
316 @since 4.4.0.0
317 -}
318 forkOn :: Int -> IO () -> IO ThreadId
319 forkOn (I# cpu) action = IO $ \ s ->
320 case (forkOn# cpu action_plus s) of (# s1, tid #) -> (# s1, ThreadId tid #)
321 where
322 -- We must use 'catch' rather than 'catchException' because the action
323 -- could be bottom. #13330
324 action_plus = catch action childHandler
325
326 -- | Like 'forkIOWithUnmask', but the child thread is pinned to the
327 -- given CPU, as with 'forkOn'.
328 --
329 -- @since 4.4.0.0
330 forkOnWithUnmask :: Int -> ((forall a . IO a -> IO a) -> IO ()) -> IO ThreadId
331 forkOnWithUnmask cpu io = forkOn cpu (io unsafeUnmask)
332
333 -- | the value passed to the @+RTS -N@ flag. This is the number of
334 -- Haskell threads that can run truly simultaneously at any given
335 -- time, and is typically set to the number of physical processor cores on
336 -- the machine.
337 --
338 -- Strictly speaking it is better to use 'getNumCapabilities', because
339 -- the number of capabilities might vary at runtime.
340 --
341 numCapabilities :: Int
342 numCapabilities = unsafePerformIO $ getNumCapabilities
343
344 {- |
345 Returns the number of Haskell threads that can run truly
346 simultaneously (on separate physical processors) at any given time. To change
347 this value, use 'setNumCapabilities'.
348
349 @since 4.4.0.0
350 -}
351 getNumCapabilities :: IO Int
352 getNumCapabilities = do
353 n <- peek enabled_capabilities
354 return (fromIntegral n)
355
356 {- |
357 Set the number of Haskell threads that can run truly simultaneously
358 (on separate physical processors) at any given time. The number
359 passed to `forkOn` is interpreted modulo this value. The initial
360 value is given by the @+RTS -N@ runtime flag.
361
362 This is also the number of threads that will participate in parallel
363 garbage collection. It is strongly recommended that the number of
364 capabilities is not set larger than the number of physical processor
365 cores, and it may often be beneficial to leave one or more cores free
366 to avoid contention with other processes in the machine.
367
368 @since 4.5.0.0
369 -}
370 setNumCapabilities :: Int -> IO ()
371 setNumCapabilities i
372 | i <= 0 = fail $ "setNumCapabilities: Capability count ("++show i++") must be positive"
373 | otherwise = c_setNumCapabilities (fromIntegral i)
374
375 foreign import ccall safe "setNumCapabilities"
376 c_setNumCapabilities :: CUInt -> IO ()
377
378 -- | Returns the number of CPUs that the machine has
379 --
380 -- @since 4.5.0.0
381 getNumProcessors :: IO Int
382 getNumProcessors = fmap fromIntegral c_getNumberOfProcessors
383
384 foreign import ccall unsafe "getNumberOfProcessors"
385 c_getNumberOfProcessors :: IO CUInt
386
387 -- | Returns the number of sparks currently in the local spark pool
388 numSparks :: IO Int
389 numSparks = IO $ \s -> case numSparks# s of (# s', n #) -> (# s', I# n #)
390
391 foreign import ccall "&enabled_capabilities" enabled_capabilities :: Ptr CInt
392
393 childHandler :: SomeException -> IO ()
394 childHandler err = catch (real_handler err) childHandler
395 -- We must use catch here rather than catchException. If the
396 -- raised exception throws an (imprecise) exception, then real_handler err
397 -- will do so as well. If we use catchException here, then we could miss
398 -- that exception.
399
400 real_handler :: SomeException -> IO ()
401 real_handler se
402 | Just BlockedIndefinitelyOnMVar <- fromException se = return ()
403 | Just BlockedIndefinitelyOnSTM <- fromException se = return ()
404 | Just ThreadKilled <- fromException se = return ()
405 | Just StackOverflow <- fromException se = reportStackOverflow
406 | otherwise = reportError se
407
408 {- | 'killThread' raises the 'ThreadKilled' exception in the given
409 thread (GHC only).
410
411 > killThread tid = throwTo tid ThreadKilled
412
413 -}
414 killThread :: ThreadId -> IO ()
415 killThread tid = throwTo tid ThreadKilled
416
417 {- | 'throwTo' raises an arbitrary exception in the target thread (GHC only).
418
419 Exception delivery synchronizes between the source and target thread:
420 'throwTo' does not return until the exception has been raised in the
421 target thread. The calling thread can thus be certain that the target
422 thread has received the exception. Exception delivery is also atomic
423 with respect to other exceptions. Atomicity is a useful property to have
424 when dealing with race conditions: e.g. if there are two threads that
425 can kill each other, it is guaranteed that only one of the threads
426 will get to kill the other.
427
428 Whatever work the target thread was doing when the exception was
429 raised is not lost: the computation is suspended until required by
430 another thread.
431
432 If the target thread is currently making a foreign call, then the
433 exception will not be raised (and hence 'throwTo' will not return)
434 until the call has completed. This is the case regardless of whether
435 the call is inside a 'mask' or not. However, in GHC a foreign call
436 can be annotated as @interruptible@, in which case a 'throwTo' will
437 cause the RTS to attempt to cause the call to return; see the GHC
438 documentation for more details.
439
440 Important note: the behaviour of 'throwTo' differs from that described in
441 the paper \"Asynchronous exceptions in Haskell\"
442 (<http://research.microsoft.com/~simonpj/Papers/asynch-exns.htm>).
443 In the paper, 'throwTo' is non-blocking; but the library implementation adopts
444 a more synchronous design in which 'throwTo' does not return until the exception
445 is received by the target thread. The trade-off is discussed in Section 9 of the paper.
446 Like any blocking operation, 'throwTo' is therefore interruptible (see Section 5.3 of
447 the paper). Unlike other interruptible operations, however, 'throwTo'
448 is /always/ interruptible, even if it does not actually block.
449
450 There is no guarantee that the exception will be delivered promptly,
451 although the runtime will endeavour to ensure that arbitrary
452 delays don't occur. In GHC, an exception can only be raised when a
453 thread reaches a /safe point/, where a safe point is where memory
454 allocation occurs. Some loops do not perform any memory allocation
455 inside the loop and therefore cannot be interrupted by a 'throwTo'.
456
457 If the target of 'throwTo' is the calling thread, then the behaviour
458 is the same as 'Control.Exception.throwIO', except that the exception
459 is thrown as an asynchronous exception. This means that if there is
460 an enclosing pure computation, which would be the case if the current
461 IO operation is inside 'unsafePerformIO' or 'unsafeInterleaveIO', that
462 computation is not permanently replaced by the exception, but is
463 suspended as if it had received an asynchronous exception.
464
465 Note that if 'throwTo' is called with the current thread as the
466 target, the exception will be thrown even if the thread is currently
467 inside 'mask' or 'uninterruptibleMask'.
468 -}
469 throwTo :: Exception e => ThreadId -> e -> IO ()
470 throwTo (ThreadId tid) ex = IO $ \ s ->
471 case (killThread# tid (toException ex) s) of s1 -> (# s1, () #)
472
473 -- | Returns the 'ThreadId' of the calling thread (GHC only).
474 myThreadId :: IO ThreadId
475 myThreadId = IO $ \s ->
476 case (myThreadId# s) of (# s1, tid #) -> (# s1, ThreadId tid #)
477
478
479 -- | The 'yield' action allows (forces, in a co-operative multitasking
480 -- implementation) a context-switch to any other currently runnable
481 -- threads (if any), and is occasionally useful when implementing
482 -- concurrency abstractions.
483 yield :: IO ()
484 yield = IO $ \s ->
485 case (yield# s) of s1 -> (# s1, () #)
486
487 {- | 'labelThread' stores a string as identifier for this thread if
488 you built a RTS with debugging support. This identifier will be used in
489 the debugging output to make distinction of different threads easier
490 (otherwise you only have the thread state object\'s address in the heap).
491
492 Other applications like the graphical Concurrent Haskell Debugger
493 (<http://www.informatik.uni-kiel.de/~fhu/chd/>) may choose to overload
494 'labelThread' for their purposes as well.
495 -}
496
497 labelThread :: ThreadId -> String -> IO ()
498 labelThread (ThreadId t) str =
499 GHC.Foreign.withCString utf8 str $ \(Ptr p) ->
500 IO $ \ s ->
501 case labelThread# t p s of s1 -> (# s1, () #)
502
503 -- Nota Bene: 'pseq' used to be 'seq'
504 -- but 'seq' is now defined in PrelGHC
505 --
506 -- "pseq" is defined a bit weirdly (see below)
507 --
508 -- The reason for the strange "lazy" call is that
509 -- it fools the compiler into thinking that pseq and par are non-strict in
510 -- their second argument (even if it inlines pseq at the call site).
511 -- If it thinks pseq is strict in "y", then it often evaluates
512 -- "y" before "x", which is totally wrong.
513
514 {-# INLINE pseq #-}
515 pseq :: a -> b -> b
516 pseq x y = x `seq` lazy y
517
518 {-# INLINE par #-}
519 par :: a -> b -> b
520 par x y = case (par# x) of { _ -> lazy y }
521
522 -- | Internal function used by the RTS to run sparks.
523 runSparks :: IO ()
524 runSparks = IO loop
525 where loop s = case getSpark# s of
526 (# s', n, p #) ->
527 if isTrue# (n ==# 0#)
528 then (# s', () #)
529 else p `seq` loop s'
530
531 data BlockReason
532 = BlockedOnMVar
533 -- ^blocked on 'MVar'
534 {- possibly (see 'threadstatus' below):
535 | BlockedOnMVarRead
536 -- ^blocked on reading an empty 'MVar'
537 -}
538 | BlockedOnBlackHole
539 -- ^blocked on a computation in progress by another thread
540 | BlockedOnException
541 -- ^blocked in 'throwTo'
542 | BlockedOnSTM
543 -- ^blocked in 'retry' in an STM transaction
544 | BlockedOnForeignCall
545 -- ^currently in a foreign call
546 | BlockedOnOther
547 -- ^blocked on some other resource. Without @-threaded@,
548 -- I\/O and 'threadDelay' show up as 'BlockedOnOther', with @-threaded@
549 -- they show up as 'BlockedOnMVar'.
550 deriving (Eq,Ord,Show)
551
552 -- | The current status of a thread
553 data ThreadStatus
554 = ThreadRunning
555 -- ^the thread is currently runnable or running
556 | ThreadFinished
557 -- ^the thread has finished
558 | ThreadBlocked BlockReason
559 -- ^the thread is blocked on some resource
560 | ThreadDied
561 -- ^the thread received an uncaught exception
562 deriving (Eq,Ord,Show)
563
564 threadStatus :: ThreadId -> IO ThreadStatus
565 threadStatus (ThreadId t) = IO $ \s ->
566 case threadStatus# t s of
567 (# s', stat, _cap, _locked #) -> (# s', mk_stat (I# stat) #)
568 where
569 -- NB. keep these in sync with includes/rts/Constants.h
570 mk_stat 0 = ThreadRunning
571 mk_stat 1 = ThreadBlocked BlockedOnMVar
572 mk_stat 2 = ThreadBlocked BlockedOnBlackHole
573 mk_stat 6 = ThreadBlocked BlockedOnSTM
574 mk_stat 10 = ThreadBlocked BlockedOnForeignCall
575 mk_stat 11 = ThreadBlocked BlockedOnForeignCall
576 mk_stat 12 = ThreadBlocked BlockedOnException
577 mk_stat 14 = ThreadBlocked BlockedOnMVar -- possibly: BlockedOnMVarRead
578 -- NB. these are hardcoded in rts/PrimOps.cmm
579 mk_stat 16 = ThreadFinished
580 mk_stat 17 = ThreadDied
581 mk_stat _ = ThreadBlocked BlockedOnOther
582
583 -- | Returns the number of the capability on which the thread is currently
584 -- running, and a boolean indicating whether the thread is locked to
585 -- that capability or not. A thread is locked to a capability if it
586 -- was created with @forkOn@.
587 --
588 -- @since 4.4.0.0
589 threadCapability :: ThreadId -> IO (Int, Bool)
590 threadCapability (ThreadId t) = IO $ \s ->
591 case threadStatus# t s of
592 (# s', _, cap#, locked# #) -> (# s', (I# cap#, isTrue# (locked# /=# 0#)) #)
593
594 -- | Make a weak pointer to a 'ThreadId'. It can be important to do
595 -- this if you want to hold a reference to a 'ThreadId' while still
596 -- allowing the thread to receive the @BlockedIndefinitely@ family of
597 -- exceptions (e.g. 'BlockedIndefinitelyOnMVar'). Holding a normal
598 -- 'ThreadId' reference will prevent the delivery of
599 -- @BlockedIndefinitely@ exceptions because the reference could be
600 -- used as the target of 'throwTo' at any time, which would unblock
601 -- the thread.
602 --
603 -- Holding a @Weak ThreadId@, on the other hand, will not prevent the
604 -- thread from receiving @BlockedIndefinitely@ exceptions. It is
605 -- still possible to throw an exception to a @Weak ThreadId@, but the
606 -- caller must use @deRefWeak@ first to determine whether the thread
607 -- still exists.
608 --
609 -- @since 4.6.0.0
610 mkWeakThreadId :: ThreadId -> IO (Weak ThreadId)
611 mkWeakThreadId t@(ThreadId t#) = IO $ \s ->
612 case mkWeakNoFinalizer# t# t s of
613 (# s1, w #) -> (# s1, Weak w #)
614
615
616 data PrimMVar
617
618 -- | Make a StablePtr that can be passed to the C function
619 -- @hs_try_putmvar()@. The RTS wants a 'StablePtr' to the underlying
620 -- 'MVar#', but a 'StablePtr#' can only refer to lifted types, so we
621 -- have to cheat by coercing.
622 newStablePtrPrimMVar :: MVar () -> IO (StablePtr PrimMVar)
623 newStablePtrPrimMVar (MVar m) = IO $ \s0 ->
624 case makeStablePtr# (unsafeCoerce# m :: PrimMVar) s0 of
625 (# s1, sp #) -> (# s1, StablePtr sp #)
626
627 -----------------------------------------------------------------------------
628 -- Transactional heap operations
629 -----------------------------------------------------------------------------
630
631 -- TVars are shared memory locations which support atomic memory
632 -- transactions.
633
634 -- |A monad supporting atomic memory transactions.
635 newtype STM a = STM (State# RealWorld -> (# State# RealWorld, a #))
636
637 unSTM :: STM a -> (State# RealWorld -> (# State# RealWorld, a #))
638 unSTM (STM a) = a
639
640 -- | @since 4.3.0.0
641 instance Functor STM where
642 fmap f x = x >>= (pure . f)
643
644 -- | @since 4.8.0.0
645 instance Applicative STM where
646 {-# INLINE pure #-}
647 {-# INLINE (*>) #-}
648 {-# INLINE liftA2 #-}
649 pure x = returnSTM x
650 (<*>) = ap
651 liftA2 = liftM2
652 m *> k = thenSTM m k
653
654 -- | @since 4.3.0.0
655 instance Monad STM where
656 {-# INLINE (>>=) #-}
657 m >>= k = bindSTM m k
658 (>>) = (*>)
659
660 bindSTM :: STM a -> (a -> STM b) -> STM b
661 bindSTM (STM m) k = STM ( \s ->
662 case m s of
663 (# new_s, a #) -> unSTM (k a) new_s
664 )
665
666 thenSTM :: STM a -> STM b -> STM b
667 thenSTM (STM m) k = STM ( \s ->
668 case m s of
669 (# new_s, _ #) -> unSTM k new_s
670 )
671
672 returnSTM :: a -> STM a
673 returnSTM x = STM (\s -> (# s, x #))
674
675 -- | @since 4.8.0.0
676 instance Alternative STM where
677 empty = retry
678 (<|>) = orElse
679
680 -- | @since 4.3.0.0
681 instance MonadPlus STM
682
683 -- | Unsafely performs IO in the STM monad. Beware: this is a highly
684 -- dangerous thing to do.
685 --
686 -- * The STM implementation will often run transactions multiple
687 -- times, so you need to be prepared for this if your IO has any
688 -- side effects.
689 --
690 -- * The STM implementation will abort transactions that are known to
691 -- be invalid and need to be restarted. This may happen in the middle
692 -- of `unsafeIOToSTM`, so make sure you don't acquire any resources
693 -- that need releasing (exception handlers are ignored when aborting
694 -- the transaction). That includes doing any IO using Handles, for
695 -- example. Getting this wrong will probably lead to random deadlocks.
696 --
697 -- * The transaction may have seen an inconsistent view of memory when
698 -- the IO runs. Invariants that you expect to be true throughout
699 -- your program may not be true inside a transaction, due to the
700 -- way transactions are implemented. Normally this wouldn't be visible
701 -- to the programmer, but using `unsafeIOToSTM` can expose it.
702 --
703 unsafeIOToSTM :: IO a -> STM a
704 unsafeIOToSTM (IO m) = STM m
705
706 -- | Perform a series of STM actions atomically.
707 --
708 -- Using 'atomically' inside an 'unsafePerformIO' or 'unsafeInterleaveIO'
709 -- subverts some of guarantees that STM provides. It makes it possible to
710 -- run a transaction inside of another transaction, depending on when the
711 -- thunk is evaluated. If a nested transaction is attempted, an exception
712 -- is thrown by the runtime. It is possible to safely use 'atomically' inside
713 -- 'unsafePerformIO' or 'unsafeInterleaveIO', but the typechecker does not
714 -- rule out programs that may attempt nested transactions, meaning that
715 -- the programmer must take special care to prevent these.
716 --
717 -- However, there are functions for creating transactional variables that
718 -- can always be safely called in 'unsafePerformIO'. See: 'newTVarIO',
719 -- 'newTChanIO', 'newBroadcastTChanIO', 'newTQueueIO', 'newTBQueueIO',
720 -- and 'newTMVarIO'.
721 --
722 -- Using 'unsafePerformIO' inside of 'atomically' is also dangerous but for
723 -- different reasons. See 'unsafeIOToSTM' for more on this.
724
725 atomically :: STM a -> IO a
726 atomically (STM m) = IO (\s -> (atomically# m) s )
727
728 -- | Retry execution of the current memory transaction because it has seen
729 -- values in 'TVar's which mean that it should not continue (e.g. the 'TVar's
730 -- represent a shared buffer that is now empty). The implementation may
731 -- block the thread until one of the 'TVar's that it has read from has been
732 -- updated. (GHC only)
733 retry :: STM a
734 retry = STM $ \s# -> retry# s#
735
736 -- | Compose two alternative STM actions (GHC only).
737 --
738 -- If the first action completes without retrying then it forms the result of
739 -- the 'orElse'. Otherwise, if the first action retries, then the second action
740 -- is tried in its place. If both actions retry then the 'orElse' as a whole
741 -- retries.
742 orElse :: STM a -> STM a -> STM a
743 orElse (STM m) e = STM $ \s -> catchRetry# m (unSTM e) s
744
745 -- | A variant of 'throw' that can only be used within the 'STM' monad.
746 --
747 -- Throwing an exception in @STM@ aborts the transaction and propagates the
748 -- exception.
749 --
750 -- Although 'throwSTM' has a type that is an instance of the type of 'throw', the
751 -- two functions are subtly different:
752 --
753 -- > throw e `seq` x ===> throw e
754 -- > throwSTM e `seq` x ===> x
755 --
756 -- The first example will cause the exception @e@ to be raised,
757 -- whereas the second one won\'t. In fact, 'throwSTM' will only cause
758 -- an exception to be raised when it is used within the 'STM' monad.
759 -- The 'throwSTM' variant should be used in preference to 'throw' to
760 -- raise an exception within the 'STM' monad because it guarantees
761 -- ordering with respect to other 'STM' operations, whereas 'throw'
762 -- does not.
763 throwSTM :: Exception e => e -> STM a
764 throwSTM e = STM $ raiseIO# (toException e)
765
766 -- |Exception handling within STM actions.
767 catchSTM :: Exception e => STM a -> (e -> STM a) -> STM a
768 catchSTM (STM m) handler = STM $ catchSTM# m handler'
769 where
770 handler' e = case fromException e of
771 Just e' -> unSTM (handler e')
772 Nothing -> raiseIO# e
773
774 -- | Low-level primitive on which 'always' and 'alwaysSucceeds' are built.
775 -- 'checkInv' differs from these in that,
776 --
777 -- 1. the invariant is not checked when 'checkInv' is called, only at the end of
778 -- this and subsequent transactions
779 -- 2. the invariant failure is indicated by raising an exception.
780 checkInv :: STM a -> STM ()
781 checkInv (STM m) = STM (\s -> case (check# m) s of s' -> (# s', () #))
782
783 -- | 'alwaysSucceeds' adds a new invariant that must be true when passed
784 -- to 'alwaysSucceeds', at the end of the current transaction, and at
785 -- the end of every subsequent transaction. If it fails at any
786 -- of those points then the transaction violating it is aborted
787 -- and the exception raised by the invariant is propagated.
788 alwaysSucceeds :: STM a -> STM ()
789 alwaysSucceeds i = do ( i >> retry ) `orElse` ( return () )
790 checkInv i
791
792 -- | 'always' is a variant of 'alwaysSucceeds' in which the invariant is
793 -- expressed as an @STM Bool@ action that must return @True@. Returning
794 -- @False@ or raising an exception are both treated as invariant failures.
795 always :: STM Bool -> STM ()
796 always i = alwaysSucceeds ( do v <- i
797 if (v) then return () else ( errorWithoutStackTrace "Transactional invariant violation" ) )
798
799 -- |Shared memory locations that support atomic memory transactions.
800 data TVar a = TVar (TVar# RealWorld a)
801
802 -- | @since 4.8.0.0
803 instance Eq (TVar a) where
804 (TVar tvar1#) == (TVar tvar2#) = isTrue# (sameTVar# tvar1# tvar2#)
805
806 -- | Create a new 'TVar' holding a value supplied
807 newTVar :: a -> STM (TVar a)
808 newTVar val = STM $ \s1# ->
809 case newTVar# val s1# of
810 (# s2#, tvar# #) -> (# s2#, TVar tvar# #)
811
812 -- | @IO@ version of 'newTVar'. This is useful for creating top-level
813 -- 'TVar's using 'System.IO.Unsafe.unsafePerformIO', because using
814 -- 'atomically' inside 'System.IO.Unsafe.unsafePerformIO' isn't
815 -- possible.
816 newTVarIO :: a -> IO (TVar a)
817 newTVarIO val = IO $ \s1# ->
818 case newTVar# val s1# of
819 (# s2#, tvar# #) -> (# s2#, TVar tvar# #)
820
821 -- | Return the current value stored in a 'TVar'.
822 -- This is equivalent to
823 --
824 -- > readTVarIO = atomically . readTVar
825 --
826 -- but works much faster, because it doesn't perform a complete
827 -- transaction, it just reads the current value of the 'TVar'.
828 readTVarIO :: TVar a -> IO a
829 readTVarIO (TVar tvar#) = IO $ \s# -> readTVarIO# tvar# s#
830
831 -- |Return the current value stored in a 'TVar'.
832 readTVar :: TVar a -> STM a
833 readTVar (TVar tvar#) = STM $ \s# -> readTVar# tvar# s#
834
835 -- |Write the supplied value into a 'TVar'.
836 writeTVar :: TVar a -> a -> STM ()
837 writeTVar (TVar tvar#) val = STM $ \s1# ->
838 case writeTVar# tvar# val s1# of
839 s2# -> (# s2#, () #)
840
841 -----------------------------------------------------------------------------
842 -- MVar utilities
843 -----------------------------------------------------------------------------
844
845 -- | Provide an 'IO' action with the current value of an 'MVar'. The 'MVar'
846 -- will be empty for the duration that the action is running.
847 withMVar :: MVar a -> (a -> IO b) -> IO b
848 withMVar m io =
849 mask $ \restore -> do
850 a <- takeMVar m
851 b <- catchAny (restore (io a))
852 (\e -> do putMVar m a; throw e)
853 putMVar m a
854 return b
855
856 -- | Modify the value of an 'MVar'.
857 modifyMVar_ :: MVar a -> (a -> IO a) -> IO ()
858 modifyMVar_ m io =
859 mask $ \restore -> do
860 a <- takeMVar m
861 a' <- catchAny (restore (io a))
862 (\e -> do putMVar m a; throw e)
863 putMVar m a'
864 return ()
865
866 -----------------------------------------------------------------------------
867 -- Thread waiting
868 -----------------------------------------------------------------------------
869
870 -- Machinery needed to ensure that we only have one copy of certain
871 -- CAFs in this module even when the base package is present twice, as
872 -- it is when base is dynamically loaded into GHCi. The RTS keeps
873 -- track of the single true value of the CAF, so even when the CAFs in
874 -- the dynamically-loaded base package are reverted, nothing bad
875 -- happens.
876 --
877 sharedCAF :: a -> (Ptr a -> IO (Ptr a)) -> IO a
878 sharedCAF a get_or_set =
879 mask_ $ do
880 stable_ref <- newStablePtr a
881 let ref = castPtr (castStablePtrToPtr stable_ref)
882 ref2 <- get_or_set ref
883 if ref==ref2
884 then return a
885 else do freeStablePtr stable_ref
886 deRefStablePtr (castPtrToStablePtr (castPtr ref2))
887
888 reportStackOverflow :: IO ()
889 reportStackOverflow = do
890 ThreadId tid <- myThreadId
891 c_reportStackOverflow tid
892
893 reportError :: SomeException -> IO ()
894 reportError ex = do
895 handler <- getUncaughtExceptionHandler
896 handler ex
897
898 -- SUP: Are the hooks allowed to re-enter Haskell land? If so, remove
899 -- the unsafe below.
900 foreign import ccall unsafe "reportStackOverflow"
901 c_reportStackOverflow :: ThreadId# -> IO ()
902
903 foreign import ccall unsafe "reportHeapOverflow"
904 reportHeapOverflow :: IO ()
905
906 {-# NOINLINE uncaughtExceptionHandler #-}
907 uncaughtExceptionHandler :: IORef (SomeException -> IO ())
908 uncaughtExceptionHandler = unsafePerformIO (newIORef defaultHandler)
909 where
910 defaultHandler :: SomeException -> IO ()
911 defaultHandler se@(SomeException ex) = do
912 (hFlush stdout) `catchAny` (\ _ -> return ())
913 let msg = case cast ex of
914 Just Deadlock -> "no threads to run: infinite loop or deadlock?"
915 _ -> showsPrec 0 se ""
916 withCString "%s" $ \cfmt ->
917 withCString msg $ \cmsg ->
918 errorBelch cfmt cmsg
919
920 -- don't use errorBelch() directly, because we cannot call varargs functions
921 -- using the FFI.
922 foreign import ccall unsafe "HsBase.h errorBelch2"
923 errorBelch :: CString -> CString -> IO ()
924
925 setUncaughtExceptionHandler :: (SomeException -> IO ()) -> IO ()
926 setUncaughtExceptionHandler = writeIORef uncaughtExceptionHandler
927
928 getUncaughtExceptionHandler :: IO (SomeException -> IO ())
929 getUncaughtExceptionHandler = readIORef uncaughtExceptionHandler