<?xml version="1.0" encoding="UTF-8"?>
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
<html>
<head>
<!-- Generated by HsColour, http://www.cs.york.ac.uk/fp/darcs/hscolour/ -->
<title>GHC/Conc/Sync.lhs</title>
<link type='text/css' rel='stylesheet' href='hscolour.css' />
</head>
<body>
\begin{code}
<pre><a name="line-1"></a><span class='hs-comment'>{-# OPTIONS_GHC -XNoImplicitPrelude #-}</span>
<a name="line-2"></a><span class='hs-comment'>{-# OPTIONS_GHC -fno-warn-missing-signatures #-}</span>
<a name="line-3"></a><span class='hs-comment'>{-# OPTIONS_HADDOCK not-home #-}</span>
<a name="line-4"></a><span class='hs-comment'>-----------------------------------------------------------------------------</span>
<a name="line-5"></a><span class='hs-comment'>-- |</span>
<a name="line-6"></a><span class='hs-comment'>-- Module : GHC.Conc.Sync</span>
<a name="line-7"></a><span class='hs-comment'>-- Copyright : (c) The University of Glasgow, 1994-2002</span>
<a name="line-8"></a><span class='hs-comment'>-- License : see libraries/base/LICENSE</span>
<a name="line-9"></a><span class='hs-comment'>--</span>
<a name="line-10"></a><span class='hs-comment'>-- Maintainer : cvs-ghc@haskell.org</span>
<a name="line-11"></a><span class='hs-comment'>-- Stability : internal</span>
<a name="line-12"></a><span class='hs-comment'>-- Portability : non-portable (GHC extensions)</span>
<a name="line-13"></a><span class='hs-comment'>--</span>
<a name="line-14"></a><span class='hs-comment'>-- Basic concurrency stuff.</span>
<a name="line-15"></a><span class='hs-comment'>--</span>
<a name="line-16"></a><span class='hs-comment'>-----------------------------------------------------------------------------</span>
<a name="line-17"></a>
<a name="line-18"></a><span class='hs-comment'>-- No: #hide, because bits of this module are exposed by the stm package.</span>
<a name="line-19"></a><span class='hs-comment'>-- However, we don't want this module to be the home location for the</span>
<a name="line-20"></a><span class='hs-comment'>-- bits it exports, we'd rather have Control.Concurrent and the other</span>
<a name="line-21"></a><span class='hs-comment'>-- higher level modules be the home. Hence:</span>
<a name="line-22"></a>
<a name="line-23"></a><span class='hs-cpp'>#include "Typeable.h"</span>
<a name="line-24"></a>
<a name="line-25"></a><span class='hs-comment'>-- #not-home</span>
<a name="line-26"></a><span class='hs-keyword'>module</span> <span class='hs-conid'>GHC</span><span class='hs-varop'>.</span><span class='hs-conid'>Conc</span><span class='hs-varop'>.</span><span class='hs-conid'>Sync</span>
<a name="line-27"></a> <span class='hs-layout'>(</span> <span class='hs-conid'>ThreadId</span><span class='hs-layout'>(</span><span class='hs-keyglyph'>..</span><span class='hs-layout'>)</span>
<a name="line-28"></a>
<a name="line-29"></a> <span class='hs-comment'>-- * Forking and suchlike</span>
<a name="line-30"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>forkIO</span> <span class='hs-comment'>-- :: IO a -> IO ThreadId</span>
<a name="line-31"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>forkIOUnmasked</span>
<a name="line-32"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>forkOnIO</span> <span class='hs-comment'>-- :: Int -> IO a -> IO ThreadId</span>
<a name="line-33"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>forkOnIOUnmasked</span>
<a name="line-34"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>numCapabilities</span> <span class='hs-comment'>-- :: Int</span>
<a name="line-35"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>numSparks</span> <span class='hs-comment'>-- :: IO Int</span>
<a name="line-36"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>childHandler</span> <span class='hs-comment'>-- :: Exception -> IO ()</span>
<a name="line-37"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>myThreadId</span> <span class='hs-comment'>-- :: IO ThreadId</span>
<a name="line-38"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>killThread</span> <span class='hs-comment'>-- :: ThreadId -> IO ()</span>
<a name="line-39"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>throwTo</span> <span class='hs-comment'>-- :: ThreadId -> Exception -> IO ()</span>
<a name="line-40"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>par</span> <span class='hs-comment'>-- :: a -> b -> b</span>
<a name="line-41"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>pseq</span> <span class='hs-comment'>-- :: a -> b -> b</span>
<a name="line-42"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>runSparks</span>
<a name="line-43"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>yield</span> <span class='hs-comment'>-- :: IO ()</span>
<a name="line-44"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>labelThread</span> <span class='hs-comment'>-- :: ThreadId -> String -> IO ()</span>
<a name="line-45"></a>
<a name="line-46"></a> <span class='hs-layout'>,</span> <span class='hs-conid'>ThreadStatus</span><span class='hs-layout'>(</span><span class='hs-keyglyph'>..</span><span class='hs-layout'>)</span><span class='hs-layout'>,</span> <span class='hs-conid'>BlockReason</span><span class='hs-layout'>(</span><span class='hs-keyglyph'>..</span><span class='hs-layout'>)</span>
<a name="line-47"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>threadStatus</span> <span class='hs-comment'>-- :: ThreadId -> IO ThreadStatus</span>
<a name="line-48"></a>
<a name="line-49"></a> <span class='hs-comment'>-- * TVars</span>
<a name="line-50"></a> <span class='hs-layout'>,</span> <span class='hs-conid'>STM</span><span class='hs-layout'>(</span><span class='hs-keyglyph'>..</span><span class='hs-layout'>)</span>
<a name="line-51"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>atomically</span> <span class='hs-comment'>-- :: STM a -> IO a</span>
<a name="line-52"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>retry</span> <span class='hs-comment'>-- :: STM a</span>
<a name="line-53"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>orElse</span> <span class='hs-comment'>-- :: STM a -> STM a -> STM a</span>
<a name="line-54"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>throwSTM</span> <span class='hs-comment'>-- :: Exception e => e -> STM a</span>
<a name="line-55"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>catchSTM</span> <span class='hs-comment'>-- :: Exception e => STM a -> (e -> STM a) -> STM a</span>
<a name="line-56"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>alwaysSucceeds</span> <span class='hs-comment'>-- :: STM a -> STM ()</span>
<a name="line-57"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>always</span> <span class='hs-comment'>-- :: STM Bool -> STM ()</span>
<a name="line-58"></a> <span class='hs-layout'>,</span> <span class='hs-conid'>TVar</span><span class='hs-layout'>(</span><span class='hs-keyglyph'>..</span><span class='hs-layout'>)</span>
<a name="line-59"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>newTVar</span> <span class='hs-comment'>-- :: a -> STM (TVar a)</span>
<a name="line-60"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>newTVarIO</span> <span class='hs-comment'>-- :: a -> STM (TVar a)</span>
<a name="line-61"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>readTVar</span> <span class='hs-comment'>-- :: TVar a -> STM a</span>
<a name="line-62"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>readTVarIO</span> <span class='hs-comment'>-- :: TVar a -> IO a</span>
<a name="line-63"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>writeTVar</span> <span class='hs-comment'>-- :: a -> TVar a -> STM ()</span>
<a name="line-64"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>unsafeIOToSTM</span> <span class='hs-comment'>-- :: IO a -> STM a</span>
<a name="line-65"></a>
<a name="line-66"></a> <span class='hs-comment'>-- * Miscellaneous</span>
<a name="line-67"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>withMVar</span>
<a name="line-68"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>modifyMVar_</span>
<a name="line-69"></a>
<a name="line-70"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>setUncaughtExceptionHandler</span> <span class='hs-comment'>-- :: (Exception -> IO ()) -> IO ()</span>
<a name="line-71"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>getUncaughtExceptionHandler</span> <span class='hs-comment'>-- :: IO (Exception -> IO ())</span>
<a name="line-72"></a>
<a name="line-73"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>reportError</span><span class='hs-layout'>,</span> <span class='hs-varid'>reportStackOverflow</span>
<a name="line-74"></a>
<a name="line-75"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>sharedCAF</span>
<a name="line-76"></a> <span class='hs-layout'>)</span> <span class='hs-keyword'>where</span>
<a name="line-77"></a>
<a name="line-78"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>Foreign</span> <span class='hs-varid'>hiding</span> <span class='hs-layout'>(</span><span class='hs-varid'>unsafePerformIO</span><span class='hs-layout'>)</span>
<a name="line-79"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>Foreign</span><span class='hs-varop'>.</span><span class='hs-conid'>C</span>
<a name="line-80"></a>
<a name="line-81"></a><span class='hs-cpp'>#ifdef mingw32_HOST_OS</span>
<a name="line-82"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>Data</span><span class='hs-varop'>.</span><span class='hs-conid'>Typeable</span>
<a name="line-83"></a><span class='hs-cpp'>#endif</span>
<a name="line-84"></a>
<a name="line-85"></a><span class='hs-cpp'>#ifndef mingw32_HOST_OS</span>
<a name="line-86"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>Data</span><span class='hs-varop'>.</span><span class='hs-conid'>Dynamic</span>
<a name="line-87"></a><span class='hs-cpp'>#endif</span>
<a name="line-88"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>Control</span><span class='hs-varop'>.</span><span class='hs-conid'>Monad</span>
<a name="line-89"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>Data</span><span class='hs-varop'>.</span><span class='hs-conid'>Maybe</span>
<a name="line-90"></a>
<a name="line-91"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>GHC</span><span class='hs-varop'>.</span><span class='hs-conid'>Base</span>
<a name="line-92"></a><span class='hs-keyword'>import</span> <span class='hs-comment'>{-# SOURCE #-}</span> <span class='hs-conid'>GHC</span><span class='hs-varop'>.</span><span class='hs-conid'>IO</span><span class='hs-varop'>.</span><span class='hs-conid'>Handle</span> <span class='hs-layout'>(</span> <span class='hs-varid'>hFlush</span> <span class='hs-layout'>)</span>
<a name="line-93"></a><span class='hs-keyword'>import</span> <span class='hs-comment'>{-# SOURCE #-}</span> <span class='hs-conid'>GHC</span><span class='hs-varop'>.</span><span class='hs-conid'>IO</span><span class='hs-varop'>.</span><span class='hs-conid'>Handle</span><span class='hs-varop'>.</span><span class='hs-conid'>FD</span> <span class='hs-layout'>(</span> <span class='hs-varid'>stdout</span> <span class='hs-layout'>)</span>
<a name="line-94"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>GHC</span><span class='hs-varop'>.</span><span class='hs-conid'>IO</span>
<a name="line-95"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>GHC</span><span class='hs-varop'>.</span><span class='hs-conid'>IO</span><span class='hs-varop'>.</span><span class='hs-conid'>Exception</span>
<a name="line-96"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>GHC</span><span class='hs-varop'>.</span><span class='hs-conid'>Exception</span>
<a name="line-97"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>GHC</span><span class='hs-varop'>.</span><span class='hs-conid'>IORef</span>
<a name="line-98"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>GHC</span><span class='hs-varop'>.</span><span class='hs-conid'>MVar</span>
<a name="line-99"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>GHC</span><span class='hs-varop'>.</span><span class='hs-conid'>Real</span> <span class='hs-layout'>(</span> <span class='hs-varid'>fromIntegral</span> <span class='hs-layout'>)</span>
<a name="line-100"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>GHC</span><span class='hs-varop'>.</span><span class='hs-conid'>Pack</span> <span class='hs-layout'>(</span> <span class='hs-varid'>packCString</span><span class='hs-cpp'>#</span> <span class='hs-layout'>)</span>
<a name="line-101"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>GHC</span><span class='hs-varop'>.</span><span class='hs-conid'>Show</span> <span class='hs-layout'>(</span> <span class='hs-conid'>Show</span><span class='hs-layout'>(</span><span class='hs-keyglyph'>..</span><span class='hs-layout'>)</span><span class='hs-layout'>,</span> <span class='hs-varid'>showString</span> <span class='hs-layout'>)</span>
<a name="line-102"></a>
<a name="line-103"></a><span class='hs-keyword'>infixr</span> <span class='hs-num'>0</span> <span class='hs-varop'>`par`</span><span class='hs-layout'>,</span> <span class='hs-varop'>`pseq`</span>
</pre>\end{code}
%************************************************************************
%* *
\subsection{@ThreadId@, @par@, and @fork@}
%* *
%************************************************************************
\begin{code}
<pre><a name="line-1"></a><a name="ThreadId"></a><span class='hs-keyword'>data</span> <span class='hs-conid'>ThreadId</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>ThreadId</span> <span class='hs-conid'>ThreadId</span><span class='hs-cpp'>#</span> <span class='hs-keyword'>deriving</span><span class='hs-layout'>(</span> <span class='hs-conid'>Typeable</span> <span class='hs-layout'>)</span>
<a name="line-2"></a><span class='hs-comment'>-- ToDo: data ThreadId = ThreadId (Weak ThreadId#)</span>
<a name="line-3"></a><span class='hs-comment'>-- But since ThreadId# is unlifted, the Weak type must use open</span>
<a name="line-4"></a><span class='hs-comment'>-- type variables.</span>
<a name="line-5"></a><span class='hs-comment'>{- ^
<a name="line-6"></a>A 'ThreadId' is an abstract type representing a handle to a thread.
<a name="line-7"></a>'ThreadId' is an instance of 'Eq', 'Ord' and 'Show', where
<a name="line-8"></a>the 'Ord' instance implements an arbitrary total ordering over
<a name="line-9"></a>'ThreadId's. The 'Show' instance lets you convert an arbitrary-valued
<a name="line-10"></a>'ThreadId' to string form; showing a 'ThreadId' value is occasionally
<a name="line-11"></a>useful when debugging or diagnosing the behaviour of a concurrent
<a name="line-12"></a>program.
<a name="line-13"></a>
<a name="line-14"></a>/Note/: in GHC, if you have a 'ThreadId', you essentially have
<a name="line-15"></a>a pointer to the thread itself. This means the thread itself can\'t be
<a name="line-16"></a>garbage collected until you drop the 'ThreadId'.
<a name="line-17"></a>This misfeature will hopefully be corrected at a later date.
<a name="line-18"></a>
<a name="line-19"></a>/Note/: Hugs does not provide any operations on other threads;
<a name="line-20"></a>it defines 'ThreadId' as a synonym for ().
<a name="line-21"></a>-}</span>
<a name="line-22"></a>
<a name="line-23"></a><span class='hs-keyword'>instance</span> <span class='hs-conid'>Show</span> <span class='hs-conid'>ThreadId</span> <span class='hs-keyword'>where</span>
<a name="line-24"></a> <span class='hs-varid'>showsPrec</span> <span class='hs-varid'>d</span> <span class='hs-varid'>t</span> <span class='hs-keyglyph'>=</span>
<a name="line-25"></a> <span class='hs-varid'>showString</span> <span class='hs-str'>"ThreadId "</span> <span class='hs-varop'>.</span>
<a name="line-26"></a> <span class='hs-varid'>showsPrec</span> <span class='hs-varid'>d</span> <span class='hs-layout'>(</span><span class='hs-varid'>getThreadId</span> <span class='hs-layout'>(</span><span class='hs-varid'>id2TSO</span> <span class='hs-varid'>t</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-27"></a>
<a name="line-28"></a><span class='hs-keyword'>foreign</span> <span class='hs-keyword'>import</span> <span class='hs-keyword'>ccall</span> <span class='hs-keyword'>unsafe</span> <span class='hs-str'>"rts_getThreadId"</span> <span class='hs-varid'>getThreadId</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>ThreadId</span><span class='hs-cpp'>#</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>CInt</span>
<a name="line-29"></a>
<a name="line-30"></a><a name="id2TSO"></a><span class='hs-definition'>id2TSO</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>ThreadId</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>ThreadId</span><span class='hs-cpp'>#</span>
<a name="line-31"></a><span class='hs-definition'>id2TSO</span> <span class='hs-layout'>(</span><span class='hs-conid'>ThreadId</span> <span class='hs-varid'>t</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>t</span>
<a name="line-32"></a>
<a name="line-33"></a><span class='hs-keyword'>foreign</span> <span class='hs-keyword'>import</span> <span class='hs-keyword'>ccall</span> <span class='hs-keyword'>unsafe</span> <span class='hs-str'>"cmp_thread"</span> <span class='hs-varid'>cmp_thread</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>ThreadId</span><span class='hs-cpp'>#</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>ThreadId</span><span class='hs-cpp'>#</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>CInt</span>
<a name="line-34"></a><span class='hs-comment'>-- Returns -1, 0, 1</span>
<a name="line-35"></a>
<a name="line-36"></a><a name="cmpThread"></a><span class='hs-definition'>cmpThread</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>ThreadId</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>ThreadId</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Ordering</span>
<a name="line-37"></a><span class='hs-definition'>cmpThread</span> <span class='hs-varid'>t1</span> <span class='hs-varid'>t2</span> <span class='hs-keyglyph'>=</span>
<a name="line-38"></a> <span class='hs-keyword'>case</span> <span class='hs-varid'>cmp_thread</span> <span class='hs-layout'>(</span><span class='hs-varid'>id2TSO</span> <span class='hs-varid'>t1</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-varid'>id2TSO</span> <span class='hs-varid'>t2</span><span class='hs-layout'>)</span> <span class='hs-keyword'>of</span>
<a name="line-39"></a> <span class='hs-comment'>-</span><span class='hs-num'>1</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>LT</span>
<a name="line-40"></a> <span class='hs-num'>0</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>EQ</span>
<a name="line-41"></a> <span class='hs-keyword'>_</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>GT</span> <span class='hs-comment'>-- must be 1</span>
<a name="line-42"></a>
<a name="line-43"></a><span class='hs-keyword'>instance</span> <span class='hs-conid'>Eq</span> <span class='hs-conid'>ThreadId</span> <span class='hs-keyword'>where</span>
<a name="line-44"></a> <span class='hs-varid'>t1</span> <span class='hs-varop'>==</span> <span class='hs-varid'>t2</span> <span class='hs-keyglyph'>=</span>
<a name="line-45"></a> <span class='hs-keyword'>case</span> <span class='hs-varid'>t1</span> <span class='hs-varop'>`cmpThread`</span> <span class='hs-varid'>t2</span> <span class='hs-keyword'>of</span>
<a name="line-46"></a> <span class='hs-conid'>EQ</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>True</span>
<a name="line-47"></a> <span class='hs-keyword'>_</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>False</span>
<a name="line-48"></a>
<a name="line-49"></a><span class='hs-keyword'>instance</span> <span class='hs-conid'>Ord</span> <span class='hs-conid'>ThreadId</span> <span class='hs-keyword'>where</span>
<a name="line-50"></a> <span class='hs-varid'>compare</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>cmpThread</span>
<a name="line-51"></a>
<a name="line-52"></a><a name="forkIO"></a><span class='hs-comment'>{- |
<a name="line-53"></a>Sparks off a new thread to run the 'IO' computation passed as the
<a name="line-54"></a>first argument, and returns the 'ThreadId' of the newly created
<a name="line-55"></a>thread.
<a name="line-56"></a>
<a name="line-57"></a>The new thread will be a lightweight thread; if you want to use a foreign
<a name="line-58"></a>library that uses thread-local storage, use 'Control.Concurrent.forkOS' instead.
<a name="line-59"></a>
<a name="line-60"></a>GHC note: the new thread inherits the /masked/ state of the parent
<a name="line-61"></a>(see 'Control.Exception.mask').
<a name="line-62"></a>
<a name="line-63"></a>The newly created thread has an exception handler that discards the
<a name="line-64"></a>exceptions 'BlockedIndefinitelyOnMVar', 'BlockedIndefinitelyOnSTM', and
<a name="line-65"></a>'ThreadKilled', and passes all other exceptions to the uncaught
<a name="line-66"></a>exception handler (see 'setUncaughtExceptionHandler').
<a name="line-67"></a>-}</span>
<a name="line-68"></a><span class='hs-definition'>forkIO</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>IO</span> <span class='hs-conid'>()</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>IO</span> <span class='hs-conid'>ThreadId</span>
<a name="line-69"></a><span class='hs-definition'>forkIO</span> <span class='hs-varid'>action</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>IO</span> <span class='hs-varop'>$</span> <span class='hs-keyglyph'>\</span> <span class='hs-varid'>s</span> <span class='hs-keyglyph'>-></span>
<a name="line-70"></a> <span class='hs-keyword'>case</span> <span class='hs-layout'>(</span><span class='hs-varid'>fork</span><span class='hs-cpp'>#</span> <span class='hs-varid'>action_plus</span> <span class='hs-varid'>s</span><span class='hs-layout'>)</span> <span class='hs-keyword'>of</span> <span class='hs-layout'>(</span><span class='hs-cpp'>#</span> <span class='hs-varid'>s1</span><span class='hs-layout'>,</span> <span class='hs-varid'>tid</span> <span class='hs-cpp'>#</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>-></span> <span class='hs-layout'>(</span><span class='hs-cpp'>#</span> <span class='hs-varid'>s1</span><span class='hs-layout'>,</span> <span class='hs-conid'>ThreadId</span> <span class='hs-varid'>tid</span> <span class='hs-cpp'>#</span><span class='hs-layout'>)</span>
<a name="line-71"></a> <span class='hs-keyword'>where</span>
<a name="line-72"></a> <span class='hs-varid'>action_plus</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>catchException</span> <span class='hs-varid'>action</span> <span class='hs-varid'>childHandler</span>
<a name="line-73"></a>
<a name="line-74"></a><a name="forkIOUnmasked"></a><span class='hs-comment'>-- | Like 'forkIO', but the child thread is created with asynchronous exceptions</span>
<a name="line-75"></a><span class='hs-comment'>-- unmasked (see 'Control.Exception.mask').</span>
<a name="line-76"></a><span class='hs-definition'>forkIOUnmasked</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>IO</span> <span class='hs-conid'>()</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>IO</span> <span class='hs-conid'>ThreadId</span>
<a name="line-77"></a><span class='hs-definition'>forkIOUnmasked</span> <span class='hs-varid'>io</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>forkIO</span> <span class='hs-layout'>(</span><span class='hs-varid'>unsafeUnmask</span> <span class='hs-varid'>io</span><span class='hs-layout'>)</span>
<a name="line-78"></a>
<a name="line-79"></a><a name="forkOnIO"></a><span class='hs-comment'>{- |
<a name="line-80"></a>Like 'forkIO', but lets you specify on which CPU the thread is
<a name="line-81"></a>created. Unlike a `forkIO` thread, a thread created by `forkOnIO`
<a name="line-82"></a>will stay on the same CPU for its entire lifetime (`forkIO` threads
<a name="line-83"></a>can migrate between CPUs according to the scheduling policy).
<a name="line-84"></a>`forkOnIO` is useful for overriding the scheduling policy when you
<a name="line-85"></a>know in advance how best to distribute the threads.
<a name="line-86"></a>
<a name="line-87"></a>The `Int` argument specifies the CPU number; it is interpreted modulo
<a name="line-88"></a>'numCapabilities' (note that it actually specifies a capability number
<a name="line-89"></a>rather than a CPU number, but to a first approximation the two are
<a name="line-90"></a>equivalent).
<a name="line-91"></a>-}</span>
<a name="line-92"></a><span class='hs-definition'>forkOnIO</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Int</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>IO</span> <span class='hs-conid'>()</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>IO</span> <span class='hs-conid'>ThreadId</span>
<a name="line-93"></a><span class='hs-definition'>forkOnIO</span> <span class='hs-layout'>(</span><span class='hs-conid'>I</span><span class='hs-cpp'>#</span> <span class='hs-varid'>cpu</span><span class='hs-layout'>)</span> <span class='hs-varid'>action</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>IO</span> <span class='hs-varop'>$</span> <span class='hs-keyglyph'>\</span> <span class='hs-varid'>s</span> <span class='hs-keyglyph'>-></span>
<a name="line-94"></a> <span class='hs-keyword'>case</span> <span class='hs-layout'>(</span><span class='hs-varid'>forkOn</span><span class='hs-cpp'>#</span> <span class='hs-varid'>cpu</span> <span class='hs-varid'>action_plus</span> <span class='hs-varid'>s</span><span class='hs-layout'>)</span> <span class='hs-keyword'>of</span> <span class='hs-layout'>(</span><span class='hs-cpp'>#</span> <span class='hs-varid'>s1</span><span class='hs-layout'>,</span> <span class='hs-varid'>tid</span> <span class='hs-cpp'>#</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>-></span> <span class='hs-layout'>(</span><span class='hs-cpp'>#</span> <span class='hs-varid'>s1</span><span class='hs-layout'>,</span> <span class='hs-conid'>ThreadId</span> <span class='hs-varid'>tid</span> <span class='hs-cpp'>#</span><span class='hs-layout'>)</span>
<a name="line-95"></a> <span class='hs-keyword'>where</span>
<a name="line-96"></a> <span class='hs-varid'>action_plus</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>catchException</span> <span class='hs-varid'>action</span> <span class='hs-varid'>childHandler</span>
<a name="line-97"></a>
<a name="line-98"></a><a name="forkOnIOUnmasked"></a><span class='hs-comment'>-- | Like 'forkOnIO', but the child thread is created with</span>
<a name="line-99"></a><span class='hs-comment'>-- asynchronous exceptions unmasked (see 'Control.Exception.mask').</span>
<a name="line-100"></a><span class='hs-definition'>forkOnIOUnmasked</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Int</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>IO</span> <span class='hs-conid'>()</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>IO</span> <span class='hs-conid'>ThreadId</span>
<a name="line-101"></a><span class='hs-definition'>forkOnIOUnmasked</span> <span class='hs-varid'>cpu</span> <span class='hs-varid'>io</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>forkOnIO</span> <span class='hs-varid'>cpu</span> <span class='hs-layout'>(</span><span class='hs-varid'>unsafeUnmask</span> <span class='hs-varid'>io</span><span class='hs-layout'>)</span>
<a name="line-102"></a>
<a name="line-103"></a><a name="numCapabilities"></a><span class='hs-comment'>-- | the value passed to the @+RTS -N@ flag. This is the number of</span>
<a name="line-104"></a><span class='hs-comment'>-- Haskell threads that can run truly simultaneously at any given</span>
<a name="line-105"></a><span class='hs-comment'>-- time, and is typically set to the number of physical CPU cores on</span>
<a name="line-106"></a><span class='hs-comment'>-- the machine.</span>
<a name="line-107"></a><span class='hs-definition'>numCapabilities</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Int</span>
<a name="line-108"></a><span class='hs-definition'>numCapabilities</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>unsafePerformIO</span> <span class='hs-varop'>$</span> <span class='hs-keyword'>do</span>
<a name="line-109"></a> <span class='hs-varid'>n</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>peek</span> <span class='hs-varid'>n_capabilities</span>
<a name="line-110"></a> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-varid'>fromIntegral</span> <span class='hs-varid'>n</span><span class='hs-layout'>)</span>
<a name="line-111"></a>
<a name="line-112"></a><a name="numSparks"></a><span class='hs-comment'>-- | Returns the number of sparks currently in the local spark pool</span>
<a name="line-113"></a><span class='hs-definition'>numSparks</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>IO</span> <span class='hs-conid'>Int</span>
<a name="line-114"></a><span class='hs-definition'>numSparks</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>IO</span> <span class='hs-varop'>$</span> <span class='hs-keyglyph'>\</span><span class='hs-varid'>s</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyword'>case</span> <span class='hs-varid'>numSparks</span><span class='hs-cpp'>#</span> <span class='hs-varid'>s</span> <span class='hs-keyword'>of</span> <span class='hs-layout'>(</span><span class='hs-cpp'>#</span> <span class='hs-varid'>s'</span><span class='hs-layout'>,</span> <span class='hs-varid'>n</span> <span class='hs-cpp'>#</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>-></span> <span class='hs-layout'>(</span><span class='hs-cpp'>#</span> <span class='hs-varid'>s'</span><span class='hs-layout'>,</span> <span class='hs-conid'>I</span><span class='hs-cpp'>#</span> <span class='hs-varid'>n</span> <span class='hs-cpp'>#</span><span class='hs-layout'>)</span>
<a name="line-115"></a>
<a name="line-116"></a><span class='hs-cpp'>#if defined(mingw32_HOST_OS) && defined(__PIC__)</span>
<a name="line-117"></a><span class='hs-keyword'>foreign</span> <span class='hs-keyword'>import</span> <span class='hs-keyword'>ccall</span> <span class='hs-str'>"_imp__n_capabilities"</span> <span class='hs-varid'>n_capabilities</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Ptr</span> <span class='hs-conid'>CInt</span>
<a name="line-118"></a><span class='hs-cpp'>#else</span>
<a name="line-119"></a><span class='hs-keyword'>foreign</span> <span class='hs-keyword'>import</span> <span class='hs-keyword'>ccall</span> <span class='hs-str'>"&n_capabilities"</span> <span class='hs-varid'>n_capabilities</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Ptr</span> <span class='hs-conid'>CInt</span>
<a name="line-120"></a><span class='hs-cpp'>#endif</span>
<a name="line-121"></a><a name="childHandler"></a><span class='hs-definition'>childHandler</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>SomeException</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>IO</span> <span class='hs-conid'>()</span>
<a name="line-122"></a><span class='hs-definition'>childHandler</span> <span class='hs-varid'>err</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>catchException</span> <span class='hs-layout'>(</span><span class='hs-varid'>real_handler</span> <span class='hs-varid'>err</span><span class='hs-layout'>)</span> <span class='hs-varid'>childHandler</span>
<a name="line-123"></a>
<a name="line-124"></a><a name="real_handler"></a><span class='hs-definition'>real_handler</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>SomeException</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>IO</span> <span class='hs-conid'>()</span>
<a name="line-125"></a><span class='hs-definition'>real_handler</span> <span class='hs-varid'>se</span><span class='hs-keyglyph'>@</span><span class='hs-layout'>(</span><span class='hs-conid'>SomeException</span> <span class='hs-varid'>ex</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span>
<a name="line-126"></a> <span class='hs-comment'>-- ignore thread GC and killThread exceptions:</span>
<a name="line-127"></a> <span class='hs-keyword'>case</span> <span class='hs-varid'>cast</span> <span class='hs-varid'>ex</span> <span class='hs-keyword'>of</span>
<a name="line-128"></a> <span class='hs-conid'>Just</span> <span class='hs-conid'>BlockedIndefinitelyOnMVar</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>return</span> <span class='hs-conid'>()</span>
<a name="line-129"></a> <span class='hs-keyword'>_</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyword'>case</span> <span class='hs-varid'>cast</span> <span class='hs-varid'>ex</span> <span class='hs-keyword'>of</span>
<a name="line-130"></a> <span class='hs-conid'>Just</span> <span class='hs-conid'>BlockedIndefinitelyOnSTM</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>return</span> <span class='hs-conid'>()</span>
<a name="line-131"></a> <span class='hs-keyword'>_</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyword'>case</span> <span class='hs-varid'>cast</span> <span class='hs-varid'>ex</span> <span class='hs-keyword'>of</span>
<a name="line-132"></a> <span class='hs-conid'>Just</span> <span class='hs-conid'>ThreadKilled</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>return</span> <span class='hs-conid'>()</span>
<a name="line-133"></a> <span class='hs-keyword'>_</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyword'>case</span> <span class='hs-varid'>cast</span> <span class='hs-varid'>ex</span> <span class='hs-keyword'>of</span>
<a name="line-134"></a> <span class='hs-comment'>-- report all others:</span>
<a name="line-135"></a> <span class='hs-conid'>Just</span> <span class='hs-conid'>StackOverflow</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>reportStackOverflow</span>
<a name="line-136"></a> <span class='hs-keyword'>_</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>reportError</span> <span class='hs-varid'>se</span>
<a name="line-137"></a>
<a name="line-138"></a><a name="killThread"></a><span class='hs-comment'>{- | 'killThread' raises the 'ThreadKilled' exception in the given
<a name="line-139"></a>thread (GHC only).
<a name="line-140"></a>
<a name="line-141"></a>> killThread tid = throwTo tid ThreadKilled
<a name="line-142"></a>
<a name="line-143"></a>-}</span>
<a name="line-144"></a><span class='hs-definition'>killThread</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>ThreadId</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>IO</span> <span class='hs-conid'>()</span>
<a name="line-145"></a><span class='hs-definition'>killThread</span> <span class='hs-varid'>tid</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>throwTo</span> <span class='hs-varid'>tid</span> <span class='hs-conid'>ThreadKilled</span>
<a name="line-146"></a>
<a name="line-147"></a><a name="throwTo"></a><span class='hs-comment'>{- | 'throwTo' raises an arbitrary exception in the target thread (GHC only).
<a name="line-148"></a>
<a name="line-149"></a>'throwTo' does not return until the exception has been raised in the
<a name="line-150"></a>target thread.
<a name="line-151"></a>The calling thread can thus be certain that the target
<a name="line-152"></a>thread has received the exception. This is a useful property to know
<a name="line-153"></a>when dealing with race conditions: eg. if there are two threads that
<a name="line-154"></a>can kill each other, it is guaranteed that only one of the threads
<a name="line-155"></a>will get to kill the other.
<a name="line-156"></a>
<a name="line-157"></a>Whatever work the target thread was doing when the exception was
<a name="line-158"></a>raised is not lost: the computation is suspended until required by
<a name="line-159"></a>another thread.
<a name="line-160"></a>
<a name="line-161"></a>If the target thread is currently making a foreign call, then the
<a name="line-162"></a>exception will not be raised (and hence 'throwTo' will not return)
<a name="line-163"></a>until the call has completed. This is the case regardless of whether
<a name="line-164"></a>the call is inside a 'mask' or not.
<a name="line-165"></a>
<a name="line-166"></a>Important note: the behaviour of 'throwTo' differs from that described in
<a name="line-167"></a>the paper \"Asynchronous exceptions in Haskell\"
<a name="line-168"></a>(<<a href="http://research.microsoft.com/~simonpj/Papers/asynch-exns.htm">http://research.microsoft.com/~simonpj/Papers/asynch-exns.htm</a>>).
<a name="line-169"></a>In the paper, 'throwTo' is non-blocking; but the library implementation adopts
<a name="line-170"></a>a more synchronous design in which 'throwTo' does not return until the exception
<a name="line-171"></a>is received by the target thread. The trade-off is discussed in Section 9 of the paper.
<a name="line-172"></a>Like any blocking operation, 'throwTo' is therefore interruptible (see Section 5.3 of
<a name="line-173"></a>the paper). Unlike other interruptible operations, however, 'throwTo'
<a name="line-174"></a>is /always/ interruptible, even if it does not actually block.
<a name="line-175"></a>
<a name="line-176"></a>There is no guarantee that the exception will be delivered promptly,
<a name="line-177"></a>although the runtime will endeavour to ensure that arbitrary
<a name="line-178"></a>delays don't occur. In GHC, an exception can only be raised when a
<a name="line-179"></a>thread reaches a /safe point/, where a safe point is where memory
<a name="line-180"></a>allocation occurs. Some loops do not perform any memory allocation
<a name="line-181"></a>inside the loop and therefore cannot be interrupted by a 'throwTo'.
<a name="line-182"></a>
<a name="line-183"></a>Blocked 'throwTo' is fair: if multiple threads are trying to throw an
<a name="line-184"></a>exception to the same target thread, they will succeed in FIFO order.
<a name="line-185"></a>
<a name="line-186"></a> -}</span>
<a name="line-187"></a><span class='hs-definition'>throwTo</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Exception</span> <span class='hs-varid'>e</span> <span class='hs-keyglyph'>=></span> <span class='hs-conid'>ThreadId</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>e</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>IO</span> <span class='hs-conid'>()</span>
<a name="line-188"></a><span class='hs-definition'>throwTo</span> <span class='hs-layout'>(</span><span class='hs-conid'>ThreadId</span> <span class='hs-varid'>tid</span><span class='hs-layout'>)</span> <span class='hs-varid'>ex</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>IO</span> <span class='hs-varop'>$</span> <span class='hs-keyglyph'>\</span> <span class='hs-varid'>s</span> <span class='hs-keyglyph'>-></span>
<a name="line-189"></a> <span class='hs-keyword'>case</span> <span class='hs-layout'>(</span><span class='hs-varid'>killThread</span><span class='hs-cpp'>#</span> <span class='hs-varid'>tid</span> <span class='hs-layout'>(</span><span class='hs-varid'>toException</span> <span class='hs-varid'>ex</span><span class='hs-layout'>)</span> <span class='hs-varid'>s</span><span class='hs-layout'>)</span> <span class='hs-keyword'>of</span> <span class='hs-varid'>s1</span> <span class='hs-keyglyph'>-></span> <span class='hs-layout'>(</span><span class='hs-cpp'>#</span> <span class='hs-varid'>s1</span><span class='hs-layout'>,</span> <span class='hs-conid'>()</span> <span class='hs-cpp'>#</span><span class='hs-layout'>)</span>
<a name="line-190"></a>
<a name="line-191"></a><a name="myThreadId"></a><span class='hs-comment'>-- | Returns the 'ThreadId' of the calling thread (GHC only).</span>
<a name="line-192"></a><span class='hs-definition'>myThreadId</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>IO</span> <span class='hs-conid'>ThreadId</span>
<a name="line-193"></a><span class='hs-definition'>myThreadId</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>IO</span> <span class='hs-varop'>$</span> <span class='hs-keyglyph'>\</span><span class='hs-varid'>s</span> <span class='hs-keyglyph'>-></span>
<a name="line-194"></a> <span class='hs-keyword'>case</span> <span class='hs-layout'>(</span><span class='hs-varid'>myThreadId</span><span class='hs-cpp'>#</span> <span class='hs-varid'>s</span><span class='hs-layout'>)</span> <span class='hs-keyword'>of</span> <span class='hs-layout'>(</span><span class='hs-cpp'>#</span> <span class='hs-varid'>s1</span><span class='hs-layout'>,</span> <span class='hs-varid'>tid</span> <span class='hs-cpp'>#</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>-></span> <span class='hs-layout'>(</span><span class='hs-cpp'>#</span> <span class='hs-varid'>s1</span><span class='hs-layout'>,</span> <span class='hs-conid'>ThreadId</span> <span class='hs-varid'>tid</span> <span class='hs-cpp'>#</span><span class='hs-layout'>)</span>
<a name="line-195"></a>
<a name="line-196"></a>
<a name="line-197"></a><a name="yield"></a><span class='hs-comment'>-- |The 'yield' action allows (forces, in a co-operative multitasking</span>
<a name="line-198"></a><span class='hs-comment'>-- implementation) a context-switch to any other currently runnable</span>
<a name="line-199"></a><span class='hs-comment'>-- threads (if any), and is occasionally useful when implementing</span>
<a name="line-200"></a><span class='hs-comment'>-- concurrency abstractions.</span>
<a name="line-201"></a><span class='hs-definition'>yield</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>IO</span> <span class='hs-conid'>()</span>
<a name="line-202"></a><span class='hs-definition'>yield</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>IO</span> <span class='hs-varop'>$</span> <span class='hs-keyglyph'>\</span><span class='hs-varid'>s</span> <span class='hs-keyglyph'>-></span>
<a name="line-203"></a> <span class='hs-keyword'>case</span> <span class='hs-layout'>(</span><span class='hs-varid'>yield</span><span class='hs-cpp'>#</span> <span class='hs-varid'>s</span><span class='hs-layout'>)</span> <span class='hs-keyword'>of</span> <span class='hs-varid'>s1</span> <span class='hs-keyglyph'>-></span> <span class='hs-layout'>(</span><span class='hs-cpp'>#</span> <span class='hs-varid'>s1</span><span class='hs-layout'>,</span> <span class='hs-conid'>()</span> <span class='hs-cpp'>#</span><span class='hs-layout'>)</span>
<a name="line-204"></a>
<a name="line-205"></a><span class='hs-comment'>{- | 'labelThread' stores a string as identifier for this thread if
<a name="line-206"></a>you built a RTS with debugging support. This identifier will be used in
<a name="line-207"></a>the debugging output to make distinction of different threads easier
<a name="line-208"></a>(otherwise you only have the thread state object\'s address in the heap).
<a name="line-209"></a>
<a name="line-210"></a>Other applications like the graphical Concurrent Haskell Debugger
<a name="line-211"></a>(<<a href="http://www.informatik.uni-kiel.de/~fhu/chd/">http://www.informatik.uni-kiel.de/~fhu/chd/</a>>) may choose to overload
<a name="line-212"></a>'labelThread' for their purposes as well.
<a name="line-213"></a>-}</span>
<a name="line-214"></a>
<a name="line-215"></a><a name="labelThread"></a><span class='hs-definition'>labelThread</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>ThreadId</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>String</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>IO</span> <span class='hs-conid'>()</span>
<a name="line-216"></a><span class='hs-definition'>labelThread</span> <span class='hs-layout'>(</span><span class='hs-conid'>ThreadId</span> <span class='hs-varid'>t</span><span class='hs-layout'>)</span> <span class='hs-varid'>str</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>IO</span> <span class='hs-varop'>$</span> <span class='hs-keyglyph'>\</span> <span class='hs-varid'>s</span> <span class='hs-keyglyph'>-></span>
<a name="line-217"></a> <span class='hs-keyword'>let</span> <span class='hs-varop'>!</span><span class='hs-varid'>ps</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>packCString</span><span class='hs-cpp'>#</span> <span class='hs-varid'>str</span>
<a name="line-218"></a> <span class='hs-varop'>!</span><span class='hs-varid'>adr</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>byteArrayContents</span><span class='hs-cpp'>#</span> <span class='hs-varid'>ps</span> <span class='hs-keyword'>in</span>
<a name="line-219"></a> <span class='hs-keyword'>case</span> <span class='hs-layout'>(</span><span class='hs-varid'>labelThread</span><span class='hs-cpp'>#</span> <span class='hs-varid'>t</span> <span class='hs-varid'>adr</span> <span class='hs-varid'>s</span><span class='hs-layout'>)</span> <span class='hs-keyword'>of</span> <span class='hs-varid'>s1</span> <span class='hs-keyglyph'>-></span> <span class='hs-layout'>(</span><span class='hs-cpp'>#</span> <span class='hs-varid'>s1</span><span class='hs-layout'>,</span> <span class='hs-conid'>()</span> <span class='hs-cpp'>#</span><span class='hs-layout'>)</span>
<a name="line-220"></a>
<a name="line-221"></a><span class='hs-comment'>-- Nota Bene: 'pseq' used to be 'seq'</span>
<a name="line-222"></a><span class='hs-comment'>-- but 'seq' is now defined in PrelGHC</span>
<a name="line-223"></a><span class='hs-comment'>--</span>
<a name="line-224"></a><span class='hs-comment'>-- "pseq" is defined a bit weirdly (see below)</span>
<a name="line-225"></a><span class='hs-comment'>--</span>
<a name="line-226"></a><span class='hs-comment'>-- The reason for the strange "lazy" call is that</span>
<a name="line-227"></a><span class='hs-comment'>-- it fools the compiler into thinking that pseq and par are non-strict in</span>
<a name="line-228"></a><span class='hs-comment'>-- their second argument (even if it inlines pseq at the call site).</span>
<a name="line-229"></a><span class='hs-comment'>-- If it thinks pseq is strict in "y", then it often evaluates</span>
<a name="line-230"></a><span class='hs-comment'>-- "y" before "x", which is totally wrong.</span>
<a name="line-231"></a>
<a name="line-232"></a><a name="pseq"></a><span class='hs-comment'>{-# INLINE pseq #-}</span>
<a name="line-233"></a><span class='hs-definition'>pseq</span> <span class='hs-keyglyph'>::</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>b</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>b</span>
<a name="line-234"></a><span class='hs-definition'>pseq</span> <span class='hs-varid'>x</span> <span class='hs-varid'>y</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>x</span> <span class='hs-varop'>`seq`</span> <span class='hs-varid'>lazy</span> <span class='hs-varid'>y</span>
<a name="line-235"></a>
<a name="line-236"></a><a name="par"></a><span class='hs-comment'>{-# INLINE par #-}</span>
<a name="line-237"></a><span class='hs-definition'>par</span> <span class='hs-keyglyph'>::</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>b</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>b</span>
<a name="line-238"></a><span class='hs-definition'>par</span> <span class='hs-varid'>x</span> <span class='hs-varid'>y</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>case</span> <span class='hs-layout'>(</span><span class='hs-varid'>par</span><span class='hs-cpp'>#</span> <span class='hs-varid'>x</span><span class='hs-layout'>)</span> <span class='hs-keyword'>of</span> <span class='hs-layout'>{</span> <span class='hs-keyword'>_</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>lazy</span> <span class='hs-varid'>y</span> <span class='hs-layout'>}</span>
<a name="line-239"></a>
<a name="line-240"></a><a name="runSparks"></a><span class='hs-comment'>-- | Internal function used by the RTS to run sparks.</span>
<a name="line-241"></a><span class='hs-definition'>runSparks</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>IO</span> <span class='hs-conid'>()</span>
<a name="line-242"></a><span class='hs-definition'>runSparks</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>IO</span> <span class='hs-varid'>loop</span>
<a name="line-243"></a> <span class='hs-keyword'>where</span> <span class='hs-varid'>loop</span> <span class='hs-varid'>s</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>case</span> <span class='hs-varid'>getSpark</span><span class='hs-cpp'>#</span> <span class='hs-varid'>s</span> <span class='hs-keyword'>of</span>
<a name="line-244"></a> <span class='hs-layout'>(</span><span class='hs-cpp'>#</span> <span class='hs-varid'>s'</span><span class='hs-layout'>,</span> <span class='hs-varid'>n</span><span class='hs-layout'>,</span> <span class='hs-varid'>p</span> <span class='hs-cpp'>#</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>-></span>
<a name="line-245"></a> <span class='hs-keyword'>if</span> <span class='hs-varid'>n</span> <span class='hs-varop'>==#</span> <span class='hs-num'>0</span><span class='hs-cpp'>#</span> <span class='hs-keyword'>then</span> <span class='hs-layout'>(</span><span class='hs-cpp'>#</span> <span class='hs-varid'>s'</span><span class='hs-layout'>,</span> <span class='hs-conid'>()</span> <span class='hs-cpp'>#</span><span class='hs-layout'>)</span>
<a name="line-246"></a> <span class='hs-keyword'>else</span> <span class='hs-varid'>p</span> <span class='hs-varop'>`seq`</span> <span class='hs-varid'>loop</span> <span class='hs-varid'>s'</span>
<a name="line-247"></a>
<a name="line-248"></a><a name="BlockReason"></a><span class='hs-keyword'>data</span> <span class='hs-conid'>BlockReason</span>
<a name="line-249"></a> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>BlockedOnMVar</span>
<a name="line-250"></a> <span class='hs-comment'>-- ^blocked on on 'MVar'</span>
<a name="line-251"></a> <span class='hs-keyglyph'>|</span> <span class='hs-conid'>BlockedOnBlackHole</span>
<a name="line-252"></a> <span class='hs-comment'>-- ^blocked on a computation in progress by another thread</span>
<a name="line-253"></a> <span class='hs-keyglyph'>|</span> <span class='hs-conid'>BlockedOnException</span>
<a name="line-254"></a> <span class='hs-comment'>-- ^blocked in 'throwTo'</span>
<a name="line-255"></a> <span class='hs-keyglyph'>|</span> <span class='hs-conid'>BlockedOnSTM</span>
<a name="line-256"></a> <span class='hs-comment'>-- ^blocked in 'retry' in an STM transaction</span>
<a name="line-257"></a> <span class='hs-keyglyph'>|</span> <span class='hs-conid'>BlockedOnForeignCall</span>
<a name="line-258"></a> <span class='hs-comment'>-- ^currently in a foreign call</span>
<a name="line-259"></a> <span class='hs-keyglyph'>|</span> <span class='hs-conid'>BlockedOnOther</span>
<a name="line-260"></a> <span class='hs-comment'>-- ^blocked on some other resource. Without @-threaded@,</span>
<a name="line-261"></a> <span class='hs-comment'>-- I\/O and 'threadDelay' show up as 'BlockedOnOther', with @-threaded@</span>
<a name="line-262"></a> <span class='hs-comment'>-- they show up as 'BlockedOnMVar'.</span>
<a name="line-263"></a> <span class='hs-keyword'>deriving</span> <span class='hs-layout'>(</span><span class='hs-conid'>Eq</span><span class='hs-layout'>,</span><span class='hs-conid'>Ord</span><span class='hs-layout'>,</span><span class='hs-conid'>Show</span><span class='hs-layout'>)</span>
<a name="line-264"></a>
<a name="line-265"></a><a name="ThreadStatus"></a><span class='hs-comment'>-- | The current status of a thread</span>
<a name="line-266"></a><a name="ThreadStatus"></a><span class='hs-keyword'>data</span> <span class='hs-conid'>ThreadStatus</span>
<a name="line-267"></a> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>ThreadRunning</span>
<a name="line-268"></a> <span class='hs-comment'>-- ^the thread is currently runnable or running</span>
<a name="line-269"></a> <span class='hs-keyglyph'>|</span> <span class='hs-conid'>ThreadFinished</span>
<a name="line-270"></a> <span class='hs-comment'>-- ^the thread has finished</span>
<a name="line-271"></a> <span class='hs-keyglyph'>|</span> <span class='hs-conid'>ThreadBlocked</span> <span class='hs-conid'>BlockReason</span>
<a name="line-272"></a> <span class='hs-comment'>-- ^the thread is blocked on some resource</span>
<a name="line-273"></a> <span class='hs-keyglyph'>|</span> <span class='hs-conid'>ThreadDied</span>
<a name="line-274"></a> <span class='hs-comment'>-- ^the thread received an uncaught exception</span>
<a name="line-275"></a> <span class='hs-keyword'>deriving</span> <span class='hs-layout'>(</span><span class='hs-conid'>Eq</span><span class='hs-layout'>,</span><span class='hs-conid'>Ord</span><span class='hs-layout'>,</span><span class='hs-conid'>Show</span><span class='hs-layout'>)</span>
<a name="line-276"></a>
<a name="line-277"></a><a name="threadStatus"></a><span class='hs-definition'>threadStatus</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>ThreadId</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>IO</span> <span class='hs-conid'>ThreadStatus</span>
<a name="line-278"></a><span class='hs-definition'>threadStatus</span> <span class='hs-layout'>(</span><span class='hs-conid'>ThreadId</span> <span class='hs-varid'>t</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>IO</span> <span class='hs-varop'>$</span> <span class='hs-keyglyph'>\</span><span class='hs-varid'>s</span> <span class='hs-keyglyph'>-></span>
<a name="line-279"></a> <span class='hs-keyword'>case</span> <span class='hs-varid'>threadStatus</span><span class='hs-cpp'>#</span> <span class='hs-varid'>t</span> <span class='hs-varid'>s</span> <span class='hs-keyword'>of</span>
<a name="line-280"></a> <span class='hs-layout'>(</span><span class='hs-cpp'>#</span> <span class='hs-varid'>s'</span><span class='hs-layout'>,</span> <span class='hs-varid'>stat</span> <span class='hs-cpp'>#</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>-></span> <span class='hs-layout'>(</span><span class='hs-cpp'>#</span> <span class='hs-varid'>s'</span><span class='hs-layout'>,</span> <span class='hs-varid'>mk_stat</span> <span class='hs-layout'>(</span><span class='hs-conid'>I</span><span class='hs-cpp'>#</span> <span class='hs-varid'>stat</span><span class='hs-layout'>)</span> <span class='hs-cpp'>#</span><span class='hs-layout'>)</span>
<a name="line-281"></a> <span class='hs-keyword'>where</span>
<a name="line-282"></a> <span class='hs-comment'>-- NB. keep these in sync with includes/Constants.h</span>
<a name="line-283"></a> <span class='hs-varid'>mk_stat</span> <span class='hs-num'>0</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>ThreadRunning</span>
<a name="line-284"></a> <span class='hs-varid'>mk_stat</span> <span class='hs-num'>1</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>ThreadBlocked</span> <span class='hs-conid'>BlockedOnMVar</span>
<a name="line-285"></a> <span class='hs-varid'>mk_stat</span> <span class='hs-num'>2</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>ThreadBlocked</span> <span class='hs-conid'>BlockedOnBlackHole</span>
<a name="line-286"></a> <span class='hs-varid'>mk_stat</span> <span class='hs-num'>3</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>ThreadBlocked</span> <span class='hs-conid'>BlockedOnException</span>
<a name="line-287"></a> <span class='hs-varid'>mk_stat</span> <span class='hs-num'>7</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>ThreadBlocked</span> <span class='hs-conid'>BlockedOnSTM</span>
<a name="line-288"></a> <span class='hs-varid'>mk_stat</span> <span class='hs-num'>11</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>ThreadBlocked</span> <span class='hs-conid'>BlockedOnForeignCall</span>
<a name="line-289"></a> <span class='hs-varid'>mk_stat</span> <span class='hs-num'>12</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>ThreadBlocked</span> <span class='hs-conid'>BlockedOnForeignCall</span>
<a name="line-290"></a> <span class='hs-varid'>mk_stat</span> <span class='hs-num'>16</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>ThreadFinished</span>
<a name="line-291"></a> <span class='hs-varid'>mk_stat</span> <span class='hs-num'>17</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>ThreadDied</span>
<a name="line-292"></a> <span class='hs-varid'>mk_stat</span> <span class='hs-keyword'>_</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>ThreadBlocked</span> <span class='hs-conid'>BlockedOnOther</span>
</pre>\end{code}
%************************************************************************
%* *
\subsection[stm]{Transactional heap operations}
%* *
%************************************************************************
TVars are shared memory locations which support atomic memory
transactions.
\begin{code}
<pre><a name="line-1"></a><a name="STM"></a><span class='hs-comment'>-- |A monad supporting atomic memory transactions.</span>
<a name="line-2"></a><a name="STM"></a><span class='hs-keyword'>newtype</span> <span class='hs-conid'>STM</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>STM</span> <span class='hs-layout'>(</span><span class='hs-conid'>State</span><span class='hs-cpp'>#</span> <span class='hs-conid'>RealWorld</span> <span class='hs-keyglyph'>-></span> <span class='hs-layout'>(</span><span class='hs-cpp'>#</span> <span class='hs-conid'>State</span><span class='hs-cpp'>#</span> <span class='hs-conid'>RealWorld</span><span class='hs-layout'>,</span> <span class='hs-varid'>a</span> <span class='hs-cpp'>#</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-3"></a>
<a name="line-4"></a><a name="unSTM"></a><span class='hs-definition'>unSTM</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>STM</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-layout'>(</span><span class='hs-conid'>State</span><span class='hs-cpp'>#</span> <span class='hs-conid'>RealWorld</span> <span class='hs-keyglyph'>-></span> <span class='hs-layout'>(</span><span class='hs-cpp'>#</span> <span class='hs-conid'>State</span><span class='hs-cpp'>#</span> <span class='hs-conid'>RealWorld</span><span class='hs-layout'>,</span> <span class='hs-varid'>a</span> <span class='hs-cpp'>#</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-5"></a><span class='hs-definition'>unSTM</span> <span class='hs-layout'>(</span><span class='hs-conid'>STM</span> <span class='hs-varid'>a</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>a</span>
<a name="line-6"></a>
<a name="line-7"></a><span class='hs-conid'>INSTANCE_TYPEABLE1</span><span class='hs-layout'>(</span><span class='hs-conid'>STM</span><span class='hs-layout'>,</span><span class='hs-varid'>stmTc</span><span class='hs-layout'>,</span><span class='hs-str'>"STM"</span><span class='hs-layout'>)</span>
<a name="line-8"></a>
<a name="line-9"></a><span class='hs-keyword'>instance</span> <span class='hs-conid'>Functor</span> <span class='hs-conid'>STM</span> <span class='hs-keyword'>where</span>
<a name="line-10"></a> <span class='hs-varid'>fmap</span> <span class='hs-varid'>f</span> <span class='hs-varid'>x</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>x</span> <span class='hs-varop'>>>=</span> <span class='hs-layout'>(</span><span class='hs-varid'>return</span> <span class='hs-varop'>.</span> <span class='hs-varid'>f</span><span class='hs-layout'>)</span>
<a name="line-11"></a>
<a name="line-12"></a><span class='hs-keyword'>instance</span> <span class='hs-conid'>Monad</span> <span class='hs-conid'>STM</span> <span class='hs-keyword'>where</span>
<a name="line-13"></a> <span class='hs-comment'>{-# INLINE return #-}</span>
<a name="line-14"></a> <span class='hs-comment'>{-# INLINE (>>) #-}</span>
<a name="line-15"></a> <span class='hs-comment'>{-# INLINE (>>=) #-}</span>
<a name="line-16"></a> <span class='hs-varid'>m</span> <span class='hs-varop'>>></span> <span class='hs-varid'>k</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>thenSTM</span> <span class='hs-varid'>m</span> <span class='hs-varid'>k</span>
<a name="line-17"></a> <span class='hs-varid'>return</span> <span class='hs-varid'>x</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>returnSTM</span> <span class='hs-varid'>x</span>
<a name="line-18"></a> <span class='hs-varid'>m</span> <span class='hs-varop'>>>=</span> <span class='hs-varid'>k</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>bindSTM</span> <span class='hs-varid'>m</span> <span class='hs-varid'>k</span>
<a name="line-19"></a>
<a name="line-20"></a><a name="bindSTM"></a><span class='hs-definition'>bindSTM</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>STM</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-layout'>(</span><span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>STM</span> <span class='hs-varid'>b</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>STM</span> <span class='hs-varid'>b</span>
<a name="line-21"></a><span class='hs-definition'>bindSTM</span> <span class='hs-layout'>(</span><span class='hs-conid'>STM</span> <span class='hs-varid'>m</span><span class='hs-layout'>)</span> <span class='hs-varid'>k</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>STM</span> <span class='hs-layout'>(</span> <span class='hs-keyglyph'>\</span><span class='hs-varid'>s</span> <span class='hs-keyglyph'>-></span>
<a name="line-22"></a> <span class='hs-keyword'>case</span> <span class='hs-varid'>m</span> <span class='hs-varid'>s</span> <span class='hs-keyword'>of</span>
<a name="line-23"></a> <span class='hs-layout'>(</span><span class='hs-cpp'>#</span> <span class='hs-varid'>new_s</span><span class='hs-layout'>,</span> <span class='hs-varid'>a</span> <span class='hs-cpp'>#</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>unSTM</span> <span class='hs-layout'>(</span><span class='hs-varid'>k</span> <span class='hs-varid'>a</span><span class='hs-layout'>)</span> <span class='hs-varid'>new_s</span>
<a name="line-24"></a> <span class='hs-layout'>)</span>
<a name="line-25"></a>
<a name="line-26"></a><a name="thenSTM"></a><span class='hs-definition'>thenSTM</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>STM</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>STM</span> <span class='hs-varid'>b</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>STM</span> <span class='hs-varid'>b</span>
<a name="line-27"></a><span class='hs-definition'>thenSTM</span> <span class='hs-layout'>(</span><span class='hs-conid'>STM</span> <span class='hs-varid'>m</span><span class='hs-layout'>)</span> <span class='hs-varid'>k</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>STM</span> <span class='hs-layout'>(</span> <span class='hs-keyglyph'>\</span><span class='hs-varid'>s</span> <span class='hs-keyglyph'>-></span>
<a name="line-28"></a> <span class='hs-keyword'>case</span> <span class='hs-varid'>m</span> <span class='hs-varid'>s</span> <span class='hs-keyword'>of</span>
<a name="line-29"></a> <span class='hs-layout'>(</span><span class='hs-cpp'>#</span> <span class='hs-varid'>new_s</span><span class='hs-layout'>,</span> <span class='hs-keyword'>_</span> <span class='hs-cpp'>#</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>unSTM</span> <span class='hs-varid'>k</span> <span class='hs-varid'>new_s</span>
<a name="line-30"></a> <span class='hs-layout'>)</span>
<a name="line-31"></a>
<a name="line-32"></a><a name="returnSTM"></a><span class='hs-definition'>returnSTM</span> <span class='hs-keyglyph'>::</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>STM</span> <span class='hs-varid'>a</span>
<a name="line-33"></a><span class='hs-definition'>returnSTM</span> <span class='hs-varid'>x</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>STM</span> <span class='hs-layout'>(</span><span class='hs-keyglyph'>\</span><span class='hs-varid'>s</span> <span class='hs-keyglyph'>-></span> <span class='hs-layout'>(</span><span class='hs-cpp'>#</span> <span class='hs-varid'>s</span><span class='hs-layout'>,</span> <span class='hs-varid'>x</span> <span class='hs-cpp'>#</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-34"></a>
<a name="line-35"></a><span class='hs-keyword'>instance</span> <span class='hs-conid'>MonadPlus</span> <span class='hs-conid'>STM</span> <span class='hs-keyword'>where</span>
<a name="line-36"></a> <span class='hs-varid'>mzero</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>retry</span>
<a name="line-37"></a> <span class='hs-varid'>mplus</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>orElse</span>
<a name="line-38"></a>
<a name="line-39"></a><a name="unsafeIOToSTM"></a><span class='hs-comment'>-- | Unsafely performs IO in the STM monad. Beware: this is a highly</span>
<a name="line-40"></a><span class='hs-comment'>-- dangerous thing to do.</span>
<a name="line-41"></a><span class='hs-comment'>--</span>
<a name="line-42"></a><span class='hs-comment'>-- * The STM implementation will often run transactions multiple</span>
<a name="line-43"></a><span class='hs-comment'>-- times, so you need to be prepared for this if your IO has any</span>
<a name="line-44"></a><span class='hs-comment'>-- side effects.</span>
<a name="line-45"></a><span class='hs-comment'>--</span>
<a name="line-46"></a><span class='hs-comment'>-- * The STM implementation will abort transactions that are known to</span>
<a name="line-47"></a><span class='hs-comment'>-- be invalid and need to be restarted. This may happen in the middle</span>
<a name="line-48"></a><span class='hs-comment'>-- of `unsafeIOToSTM`, so make sure you don't acquire any resources</span>
<a name="line-49"></a><span class='hs-comment'>-- that need releasing (exception handlers are ignored when aborting</span>
<a name="line-50"></a><span class='hs-comment'>-- the transaction). That includes doing any IO using Handles, for</span>
<a name="line-51"></a><span class='hs-comment'>-- example. Getting this wrong will probably lead to random deadlocks.</span>
<a name="line-52"></a><span class='hs-comment'>--</span>
<a name="line-53"></a><span class='hs-comment'>-- * The transaction may have seen an inconsistent view of memory when</span>
<a name="line-54"></a><span class='hs-comment'>-- the IO runs. Invariants that you expect to be true throughout</span>
<a name="line-55"></a><span class='hs-comment'>-- your program may not be true inside a transaction, due to the</span>
<a name="line-56"></a><span class='hs-comment'>-- way transactions are implemented. Normally this wouldn't be visible</span>
<a name="line-57"></a><span class='hs-comment'>-- to the programmer, but using `unsafeIOToSTM` can expose it.</span>
<a name="line-58"></a><span class='hs-comment'>--</span>
<a name="line-59"></a><span class='hs-definition'>unsafeIOToSTM</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>IO</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>STM</span> <span class='hs-varid'>a</span>
<a name="line-60"></a><span class='hs-definition'>unsafeIOToSTM</span> <span class='hs-layout'>(</span><span class='hs-conid'>IO</span> <span class='hs-varid'>m</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>STM</span> <span class='hs-varid'>m</span>
<a name="line-61"></a>
<a name="line-62"></a><span class='hs-comment'>-- |Perform a series of STM actions atomically.</span>
<a name="line-63"></a><span class='hs-comment'>--</span>
<a name="line-64"></a><span class='hs-comment'>-- You cannot use 'atomically' inside an 'unsafePerformIO' or 'unsafeInterleaveIO'.</span>
<a name="line-65"></a><span class='hs-comment'>-- Any attempt to do so will result in a runtime error. (Reason: allowing</span>
<a name="line-66"></a><span class='hs-comment'>-- this would effectively allow a transaction inside a transaction, depending</span>
<a name="line-67"></a><span class='hs-comment'>-- on exactly when the thunk is evaluated.)</span>
<a name="line-68"></a><span class='hs-comment'>--</span>
<a name="line-69"></a><span class='hs-comment'>-- However, see 'newTVarIO', which can be called inside 'unsafePerformIO',</span>
<a name="line-70"></a><span class='hs-comment'>-- and which allows top-level TVars to be allocated.</span>
<a name="line-71"></a>
<a name="line-72"></a><a name="atomically"></a><span class='hs-definition'>atomically</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>STM</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>IO</span> <span class='hs-varid'>a</span>
<a name="line-73"></a><span class='hs-definition'>atomically</span> <span class='hs-layout'>(</span><span class='hs-conid'>STM</span> <span class='hs-varid'>m</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>IO</span> <span class='hs-layout'>(</span><span class='hs-keyglyph'>\</span><span class='hs-varid'>s</span> <span class='hs-keyglyph'>-></span> <span class='hs-layout'>(</span><span class='hs-varid'>atomically</span><span class='hs-cpp'>#</span> <span class='hs-varid'>m</span><span class='hs-layout'>)</span> <span class='hs-varid'>s</span> <span class='hs-layout'>)</span>
<a name="line-74"></a>
<a name="line-75"></a><a name="retry"></a><span class='hs-comment'>-- |Retry execution of the current memory transaction because it has seen</span>
<a name="line-76"></a><span class='hs-comment'>-- values in TVars which mean that it should not continue (e.g. the TVars</span>
<a name="line-77"></a><span class='hs-comment'>-- represent a shared buffer that is now empty). The implementation may</span>
<a name="line-78"></a><span class='hs-comment'>-- block the thread until one of the TVars that it has read from has been</span>
<a name="line-79"></a><span class='hs-comment'>-- udpated. (GHC only)</span>
<a name="line-80"></a><span class='hs-definition'>retry</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>STM</span> <span class='hs-varid'>a</span>
<a name="line-81"></a><span class='hs-definition'>retry</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>STM</span> <span class='hs-varop'>$</span> <span class='hs-keyglyph'>\</span><span class='hs-varid'>s</span><span class='hs-cpp'>#</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>retry</span><span class='hs-cpp'>#</span> <span class='hs-varid'>s</span><span class='hs-cpp'>#</span>
<a name="line-82"></a>
<a name="line-83"></a><a name="orElse"></a><span class='hs-comment'>-- |Compose two alternative STM actions (GHC only). If the first action</span>
<a name="line-84"></a><span class='hs-comment'>-- completes without retrying then it forms the result of the orElse.</span>
<a name="line-85"></a><span class='hs-comment'>-- Otherwise, if the first action retries, then the second action is</span>
<a name="line-86"></a><span class='hs-comment'>-- tried in its place. If both actions retry then the orElse as a</span>
<a name="line-87"></a><span class='hs-comment'>-- whole retries.</span>
<a name="line-88"></a><span class='hs-definition'>orElse</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>STM</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>STM</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>STM</span> <span class='hs-varid'>a</span>
<a name="line-89"></a><span class='hs-definition'>orElse</span> <span class='hs-layout'>(</span><span class='hs-conid'>STM</span> <span class='hs-varid'>m</span><span class='hs-layout'>)</span> <span class='hs-varid'>e</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>STM</span> <span class='hs-varop'>$</span> <span class='hs-keyglyph'>\</span><span class='hs-varid'>s</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>catchRetry</span><span class='hs-cpp'>#</span> <span class='hs-varid'>m</span> <span class='hs-layout'>(</span><span class='hs-varid'>unSTM</span> <span class='hs-varid'>e</span><span class='hs-layout'>)</span> <span class='hs-varid'>s</span>
<a name="line-90"></a>
<a name="line-91"></a><a name="throwSTM"></a><span class='hs-comment'>-- | A variant of 'throw' that can only be used within the 'STM' monad.</span>
<a name="line-92"></a><span class='hs-comment'>--</span>
<a name="line-93"></a><span class='hs-comment'>-- Throwing an exception in @STM@ aborts the transaction and propagates the</span>
<a name="line-94"></a><span class='hs-comment'>-- exception.</span>
<a name="line-95"></a><span class='hs-comment'>--</span>
<a name="line-96"></a><span class='hs-comment'>-- Although 'throwSTM' has a type that is an instance of the type of 'throw', the</span>
<a name="line-97"></a><span class='hs-comment'>-- two functions are subtly different:</span>
<a name="line-98"></a><span class='hs-comment'>--</span>
<a name="line-99"></a><span class='hs-comment'>-- > throw e `seq` x ===> throw e</span>
<a name="line-100"></a><span class='hs-comment'>-- > throwSTM e `seq` x ===> x</span>
<a name="line-101"></a><span class='hs-comment'>--</span>
<a name="line-102"></a><span class='hs-comment'>-- The first example will cause the exception @e@ to be raised,</span>
<a name="line-103"></a><span class='hs-comment'>-- whereas the second one won\'t. In fact, 'throwSTM' will only cause</span>
<a name="line-104"></a><span class='hs-comment'>-- an exception to be raised when it is used within the 'STM' monad.</span>
<a name="line-105"></a><span class='hs-comment'>-- The 'throwSTM' variant should be used in preference to 'throw' to</span>
<a name="line-106"></a><span class='hs-comment'>-- raise an exception within the 'STM' monad because it guarantees</span>
<a name="line-107"></a><span class='hs-comment'>-- ordering with respect to other 'STM' operations, whereas 'throw'</span>
<a name="line-108"></a><span class='hs-comment'>-- does not.</span>
<a name="line-109"></a><span class='hs-definition'>throwSTM</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Exception</span> <span class='hs-varid'>e</span> <span class='hs-keyglyph'>=></span> <span class='hs-varid'>e</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>STM</span> <span class='hs-varid'>a</span>
<a name="line-110"></a><span class='hs-definition'>throwSTM</span> <span class='hs-varid'>e</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>STM</span> <span class='hs-varop'>$</span> <span class='hs-varid'>raiseIO</span><span class='hs-cpp'>#</span> <span class='hs-layout'>(</span><span class='hs-varid'>toException</span> <span class='hs-varid'>e</span><span class='hs-layout'>)</span>
<a name="line-111"></a>
<a name="line-112"></a><a name="catchSTM"></a><span class='hs-comment'>-- |Exception handling within STM actions.</span>
<a name="line-113"></a><span class='hs-definition'>catchSTM</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Exception</span> <span class='hs-varid'>e</span> <span class='hs-keyglyph'>=></span> <span class='hs-conid'>STM</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-layout'>(</span><span class='hs-varid'>e</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>STM</span> <span class='hs-varid'>a</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>STM</span> <span class='hs-varid'>a</span>
<a name="line-114"></a><span class='hs-definition'>catchSTM</span> <span class='hs-layout'>(</span><span class='hs-conid'>STM</span> <span class='hs-varid'>m</span><span class='hs-layout'>)</span> <span class='hs-varid'>handler</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>STM</span> <span class='hs-varop'>$</span> <span class='hs-varid'>catchSTM</span><span class='hs-cpp'>#</span> <span class='hs-varid'>m</span> <span class='hs-varid'>handler'</span>
<a name="line-115"></a> <span class='hs-keyword'>where</span>
<a name="line-116"></a> <span class='hs-varid'>handler'</span> <span class='hs-varid'>e</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>case</span> <span class='hs-varid'>fromException</span> <span class='hs-varid'>e</span> <span class='hs-keyword'>of</span>
<a name="line-117"></a> <span class='hs-conid'>Just</span> <span class='hs-varid'>e'</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>unSTM</span> <span class='hs-layout'>(</span><span class='hs-varid'>handler</span> <span class='hs-varid'>e'</span><span class='hs-layout'>)</span>
<a name="line-118"></a> <span class='hs-conid'>Nothing</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>raiseIO</span><span class='hs-cpp'>#</span> <span class='hs-varid'>e</span>
<a name="line-119"></a>
<a name="line-120"></a><a name="checkInv"></a><span class='hs-comment'>-- | Low-level primitive on which always and alwaysSucceeds are built.</span>
<a name="line-121"></a><span class='hs-comment'>-- checkInv differs form these in that (i) the invariant is not</span>
<a name="line-122"></a><span class='hs-comment'>-- checked when checkInv is called, only at the end of this and</span>
<a name="line-123"></a><span class='hs-comment'>-- subsequent transcations, (ii) the invariant failure is indicated</span>
<a name="line-124"></a><span class='hs-comment'>-- by raising an exception.</span>
<a name="line-125"></a><span class='hs-definition'>checkInv</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>STM</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>STM</span> <span class='hs-conid'>()</span>
<a name="line-126"></a><span class='hs-definition'>checkInv</span> <span class='hs-layout'>(</span><span class='hs-conid'>STM</span> <span class='hs-varid'>m</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>STM</span> <span class='hs-layout'>(</span><span class='hs-keyglyph'>\</span><span class='hs-varid'>s</span> <span class='hs-keyglyph'>-></span> <span class='hs-layout'>(</span><span class='hs-varid'>check</span><span class='hs-cpp'>#</span> <span class='hs-varid'>m</span><span class='hs-layout'>)</span> <span class='hs-varid'>s</span><span class='hs-layout'>)</span>
<a name="line-127"></a>
<a name="line-128"></a><a name="alwaysSucceeds"></a><span class='hs-comment'>-- | alwaysSucceeds adds a new invariant that must be true when passed</span>
<a name="line-129"></a><span class='hs-comment'>-- to alwaysSucceeds, at the end of the current transaction, and at</span>
<a name="line-130"></a><span class='hs-comment'>-- the end of every subsequent transaction. If it fails at any</span>
<a name="line-131"></a><span class='hs-comment'>-- of those points then the transaction violating it is aborted</span>
<a name="line-132"></a><span class='hs-comment'>-- and the exception raised by the invariant is propagated.</span>
<a name="line-133"></a><span class='hs-definition'>alwaysSucceeds</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>STM</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>STM</span> <span class='hs-conid'>()</span>
<a name="line-134"></a><span class='hs-definition'>alwaysSucceeds</span> <span class='hs-varid'>i</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span> <span class='hs-layout'>(</span> <span class='hs-varid'>i</span> <span class='hs-varop'>>></span> <span class='hs-varid'>retry</span> <span class='hs-layout'>)</span> <span class='hs-varop'>`orElse`</span> <span class='hs-layout'>(</span> <span class='hs-varid'>return</span> <span class='hs-conid'>()</span> <span class='hs-layout'>)</span>
<a name="line-135"></a> <span class='hs-varid'>checkInv</span> <span class='hs-varid'>i</span>
<a name="line-136"></a>
<a name="line-137"></a><a name="always"></a><span class='hs-comment'>-- | always is a variant of alwaysSucceeds in which the invariant is</span>
<a name="line-138"></a><span class='hs-comment'>-- expressed as an STM Bool action that must return True. Returning</span>
<a name="line-139"></a><span class='hs-comment'>-- False or raising an exception are both treated as invariant failures.</span>
<a name="line-140"></a><span class='hs-definition'>always</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>STM</span> <span class='hs-conid'>Bool</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>STM</span> <span class='hs-conid'>()</span>
<a name="line-141"></a><span class='hs-definition'>always</span> <span class='hs-varid'>i</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>alwaysSucceeds</span> <span class='hs-layout'>(</span> <span class='hs-keyword'>do</span> <span class='hs-varid'>v</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>i</span>
<a name="line-142"></a> <span class='hs-keyword'>if</span> <span class='hs-layout'>(</span><span class='hs-varid'>v</span><span class='hs-layout'>)</span> <span class='hs-keyword'>then</span> <span class='hs-varid'>return</span> <span class='hs-conid'>()</span> <span class='hs-keyword'>else</span> <span class='hs-layout'>(</span> <span class='hs-varid'>error</span> <span class='hs-str'>"Transacional invariant violation"</span> <span class='hs-layout'>)</span> <span class='hs-layout'>)</span>
<a name="line-143"></a>
<a name="line-144"></a><a name="TVar"></a><span class='hs-comment'>-- |Shared memory locations that support atomic memory transactions.</span>
<a name="line-145"></a><a name="TVar"></a><span class='hs-keyword'>data</span> <span class='hs-conid'>TVar</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>TVar</span> <span class='hs-layout'>(</span><span class='hs-conid'>TVar</span><span class='hs-cpp'>#</span> <span class='hs-conid'>RealWorld</span> <span class='hs-varid'>a</span><span class='hs-layout'>)</span>
<a name="line-146"></a>
<a name="line-147"></a><span class='hs-conid'>INSTANCE_TYPEABLE1</span><span class='hs-layout'>(</span><span class='hs-conid'>TVar</span><span class='hs-layout'>,</span><span class='hs-varid'>tvarTc</span><span class='hs-layout'>,</span><span class='hs-str'>"TVar"</span><span class='hs-layout'>)</span>
<a name="line-148"></a>
<a name="line-149"></a><span class='hs-keyword'>instance</span> <span class='hs-conid'>Eq</span> <span class='hs-layout'>(</span><span class='hs-conid'>TVar</span> <span class='hs-varid'>a</span><span class='hs-layout'>)</span> <span class='hs-keyword'>where</span>
<a name="line-150"></a> <span class='hs-layout'>(</span><span class='hs-conid'>TVar</span> <span class='hs-varid'>tvar1</span><span class='hs-cpp'>#</span><span class='hs-layout'>)</span> <span class='hs-varop'>==</span> <span class='hs-layout'>(</span><span class='hs-conid'>TVar</span> <span class='hs-varid'>tvar2</span><span class='hs-cpp'>#</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>sameTVar</span><span class='hs-cpp'>#</span> <span class='hs-varid'>tvar1</span><span class='hs-cpp'>#</span> <span class='hs-varid'>tvar2</span><span class='hs-cpp'>#</span>
<a name="line-151"></a>
<a name="line-152"></a><a name="newTVar"></a><span class='hs-comment'>-- |Create a new TVar holding a value supplied</span>
<a name="line-153"></a><span class='hs-definition'>newTVar</span> <span class='hs-keyglyph'>::</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>STM</span> <span class='hs-layout'>(</span><span class='hs-conid'>TVar</span> <span class='hs-varid'>a</span><span class='hs-layout'>)</span>
<a name="line-154"></a><span class='hs-definition'>newTVar</span> <span class='hs-varid'>val</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>STM</span> <span class='hs-varop'>$</span> <span class='hs-keyglyph'>\</span><span class='hs-varid'>s1</span><span class='hs-cpp'>#</span> <span class='hs-keyglyph'>-></span>
<a name="line-155"></a> <span class='hs-keyword'>case</span> <span class='hs-varid'>newTVar</span><span class='hs-cpp'>#</span> <span class='hs-varid'>val</span> <span class='hs-varid'>s1</span><span class='hs-cpp'>#</span> <span class='hs-keyword'>of</span>
<a name="line-156"></a> <span class='hs-layout'>(</span><span class='hs-cpp'>#</span> <span class='hs-varid'>s2</span><span class='hs-cpp'>#</span><span class='hs-layout'>,</span> <span class='hs-varid'>tvar</span><span class='hs-cpp'>#</span> <span class='hs-cpp'>#</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>-></span> <span class='hs-layout'>(</span><span class='hs-cpp'>#</span> <span class='hs-varid'>s2</span><span class='hs-cpp'>#</span><span class='hs-layout'>,</span> <span class='hs-conid'>TVar</span> <span class='hs-varid'>tvar</span><span class='hs-cpp'>#</span> <span class='hs-cpp'>#</span><span class='hs-layout'>)</span>
<a name="line-157"></a>
<a name="line-158"></a><a name="newTVarIO"></a><span class='hs-comment'>-- |@IO@ version of 'newTVar'. This is useful for creating top-level</span>
<a name="line-159"></a><span class='hs-comment'>-- 'TVar's using 'System.IO.Unsafe.unsafePerformIO', because using</span>
<a name="line-160"></a><span class='hs-comment'>-- 'atomically' inside 'System.IO.Unsafe.unsafePerformIO' isn't</span>
<a name="line-161"></a><span class='hs-comment'>-- possible.</span>
<a name="line-162"></a><span class='hs-definition'>newTVarIO</span> <span class='hs-keyglyph'>::</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>IO</span> <span class='hs-layout'>(</span><span class='hs-conid'>TVar</span> <span class='hs-varid'>a</span><span class='hs-layout'>)</span>
<a name="line-163"></a><span class='hs-definition'>newTVarIO</span> <span class='hs-varid'>val</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>IO</span> <span class='hs-varop'>$</span> <span class='hs-keyglyph'>\</span><span class='hs-varid'>s1</span><span class='hs-cpp'>#</span> <span class='hs-keyglyph'>-></span>
<a name="line-164"></a> <span class='hs-keyword'>case</span> <span class='hs-varid'>newTVar</span><span class='hs-cpp'>#</span> <span class='hs-varid'>val</span> <span class='hs-varid'>s1</span><span class='hs-cpp'>#</span> <span class='hs-keyword'>of</span>
<a name="line-165"></a> <span class='hs-layout'>(</span><span class='hs-cpp'>#</span> <span class='hs-varid'>s2</span><span class='hs-cpp'>#</span><span class='hs-layout'>,</span> <span class='hs-varid'>tvar</span><span class='hs-cpp'>#</span> <span class='hs-cpp'>#</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>-></span> <span class='hs-layout'>(</span><span class='hs-cpp'>#</span> <span class='hs-varid'>s2</span><span class='hs-cpp'>#</span><span class='hs-layout'>,</span> <span class='hs-conid'>TVar</span> <span class='hs-varid'>tvar</span><span class='hs-cpp'>#</span> <span class='hs-cpp'>#</span><span class='hs-layout'>)</span>
<a name="line-166"></a>
<a name="line-167"></a><a name="readTVarIO"></a><span class='hs-comment'>-- |Return the current value stored in a TVar.</span>
<a name="line-168"></a><span class='hs-comment'>-- This is equivalent to</span>
<a name="line-169"></a><span class='hs-comment'>--</span>
<a name="line-170"></a><span class='hs-comment'>-- > readTVarIO = atomically . readTVar</span>
<a name="line-171"></a><span class='hs-comment'>--</span>
<a name="line-172"></a><span class='hs-comment'>-- but works much faster, because it doesn't perform a complete</span>
<a name="line-173"></a><span class='hs-comment'>-- transaction, it just reads the current value of the 'TVar'.</span>
<a name="line-174"></a><span class='hs-definition'>readTVarIO</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>TVar</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>IO</span> <span class='hs-varid'>a</span>
<a name="line-175"></a><span class='hs-definition'>readTVarIO</span> <span class='hs-layout'>(</span><span class='hs-conid'>TVar</span> <span class='hs-varid'>tvar</span><span class='hs-cpp'>#</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>IO</span> <span class='hs-varop'>$</span> <span class='hs-keyglyph'>\</span><span class='hs-varid'>s</span><span class='hs-cpp'>#</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>readTVarIO</span><span class='hs-cpp'>#</span> <span class='hs-varid'>tvar</span><span class='hs-cpp'>#</span> <span class='hs-varid'>s</span><span class='hs-cpp'>#</span>
<a name="line-176"></a>
<a name="line-177"></a><a name="readTVar"></a><span class='hs-comment'>-- |Return the current value stored in a TVar</span>
<a name="line-178"></a><span class='hs-definition'>readTVar</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>TVar</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>STM</span> <span class='hs-varid'>a</span>
<a name="line-179"></a><span class='hs-definition'>readTVar</span> <span class='hs-layout'>(</span><span class='hs-conid'>TVar</span> <span class='hs-varid'>tvar</span><span class='hs-cpp'>#</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>STM</span> <span class='hs-varop'>$</span> <span class='hs-keyglyph'>\</span><span class='hs-varid'>s</span><span class='hs-cpp'>#</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>readTVar</span><span class='hs-cpp'>#</span> <span class='hs-varid'>tvar</span><span class='hs-cpp'>#</span> <span class='hs-varid'>s</span><span class='hs-cpp'>#</span>
<a name="line-180"></a>
<a name="line-181"></a><a name="writeTVar"></a><span class='hs-comment'>-- |Write the supplied value into a TVar</span>
<a name="line-182"></a><span class='hs-definition'>writeTVar</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>TVar</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>STM</span> <span class='hs-conid'>()</span>
<a name="line-183"></a><span class='hs-definition'>writeTVar</span> <span class='hs-layout'>(</span><span class='hs-conid'>TVar</span> <span class='hs-varid'>tvar</span><span class='hs-cpp'>#</span><span class='hs-layout'>)</span> <span class='hs-varid'>val</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>STM</span> <span class='hs-varop'>$</span> <span class='hs-keyglyph'>\</span><span class='hs-varid'>s1</span><span class='hs-cpp'>#</span> <span class='hs-keyglyph'>-></span>
<a name="line-184"></a> <span class='hs-keyword'>case</span> <span class='hs-varid'>writeTVar</span><span class='hs-cpp'>#</span> <span class='hs-varid'>tvar</span><span class='hs-cpp'>#</span> <span class='hs-varid'>val</span> <span class='hs-varid'>s1</span><span class='hs-cpp'>#</span> <span class='hs-keyword'>of</span>
<a name="line-185"></a> <span class='hs-varid'>s2</span><span class='hs-cpp'>#</span> <span class='hs-keyglyph'>-></span> <span class='hs-layout'>(</span><span class='hs-cpp'>#</span> <span class='hs-varid'>s2</span><span class='hs-cpp'>#</span><span class='hs-layout'>,</span> <span class='hs-conid'>()</span> <span class='hs-cpp'>#</span><span class='hs-layout'>)</span>
<a name="line-186"></a>
</pre>\end{code}
MVar utilities
\begin{code}
<pre><a name="line-1"></a><a name="withMVar"></a><span class='hs-definition'>withMVar</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>MVar</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-layout'>(</span><span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>IO</span> <span class='hs-varid'>b</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>IO</span> <span class='hs-varid'>b</span>
<a name="line-2"></a><span class='hs-definition'>withMVar</span> <span class='hs-varid'>m</span> <span class='hs-varid'>io</span> <span class='hs-keyglyph'>=</span>
<a name="line-3"></a> <span class='hs-varid'>mask</span> <span class='hs-varop'>$</span> <span class='hs-keyglyph'>\</span><span class='hs-varid'>restore</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyword'>do</span>
<a name="line-4"></a> <span class='hs-varid'>a</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>takeMVar</span> <span class='hs-varid'>m</span>
<a name="line-5"></a> <span class='hs-varid'>b</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>catchAny</span> <span class='hs-layout'>(</span><span class='hs-varid'>restore</span> <span class='hs-layout'>(</span><span class='hs-varid'>io</span> <span class='hs-varid'>a</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-6"></a> <span class='hs-layout'>(</span><span class='hs-keyglyph'>\</span><span class='hs-varid'>e</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyword'>do</span> <span class='hs-varid'>putMVar</span> <span class='hs-varid'>m</span> <span class='hs-varid'>a</span><span class='hs-layout'>;</span> <span class='hs-varid'>throw</span> <span class='hs-varid'>e</span><span class='hs-layout'>)</span>
<a name="line-7"></a> <span class='hs-varid'>putMVar</span> <span class='hs-varid'>m</span> <span class='hs-varid'>a</span>
<a name="line-8"></a> <span class='hs-varid'>return</span> <span class='hs-varid'>b</span>
<a name="line-9"></a>
<a name="line-10"></a><a name="modifyMVar_"></a><span class='hs-definition'>modifyMVar_</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>MVar</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-layout'>(</span><span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>IO</span> <span class='hs-varid'>a</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>IO</span> <span class='hs-conid'>()</span>
<a name="line-11"></a><span class='hs-definition'>modifyMVar_</span> <span class='hs-varid'>m</span> <span class='hs-varid'>io</span> <span class='hs-keyglyph'>=</span>
<a name="line-12"></a> <span class='hs-varid'>mask</span> <span class='hs-varop'>$</span> <span class='hs-keyglyph'>\</span><span class='hs-varid'>restore</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyword'>do</span>
<a name="line-13"></a> <span class='hs-varid'>a</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>takeMVar</span> <span class='hs-varid'>m</span>
<a name="line-14"></a> <span class='hs-varid'>a'</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>catchAny</span> <span class='hs-layout'>(</span><span class='hs-varid'>restore</span> <span class='hs-layout'>(</span><span class='hs-varid'>io</span> <span class='hs-varid'>a</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-15"></a> <span class='hs-layout'>(</span><span class='hs-keyglyph'>\</span><span class='hs-varid'>e</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyword'>do</span> <span class='hs-varid'>putMVar</span> <span class='hs-varid'>m</span> <span class='hs-varid'>a</span><span class='hs-layout'>;</span> <span class='hs-varid'>throw</span> <span class='hs-varid'>e</span><span class='hs-layout'>)</span>
<a name="line-16"></a> <span class='hs-varid'>putMVar</span> <span class='hs-varid'>m</span> <span class='hs-varid'>a'</span>
<a name="line-17"></a> <span class='hs-varid'>return</span> <span class='hs-conid'>()</span>
</pre>\end{code}
%************************************************************************
%* *
\subsection{Thread waiting}
%* *
%************************************************************************
\begin{code}
<pre><a name="line-1"></a>
<a name="line-2"></a><a name="sharedCAF"></a><span class='hs-comment'>-- Machinery needed to ensureb that we only have one copy of certain</span>
<a name="line-3"></a><span class='hs-comment'>-- CAFs in this module even when the base package is present twice, as</span>
<a name="line-4"></a><span class='hs-comment'>-- it is when base is dynamically loaded into GHCi. The RTS keeps</span>
<a name="line-5"></a><span class='hs-comment'>-- track of the single true value of the CAF, so even when the CAFs in</span>
<a name="line-6"></a><span class='hs-comment'>-- the dynamically-loaded base package are reverted, nothing bad</span>
<a name="line-7"></a><span class='hs-comment'>-- happens.</span>
<a name="line-8"></a><span class='hs-comment'>--</span>
<a name="line-9"></a><span class='hs-definition'>sharedCAF</span> <span class='hs-keyglyph'>::</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-layout'>(</span><span class='hs-conid'>Ptr</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>IO</span> <span class='hs-layout'>(</span><span class='hs-conid'>Ptr</span> <span class='hs-varid'>a</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>IO</span> <span class='hs-varid'>a</span>
<a name="line-10"></a><span class='hs-definition'>sharedCAF</span> <span class='hs-varid'>a</span> <span class='hs-varid'>get_or_set</span> <span class='hs-keyglyph'>=</span>
<a name="line-11"></a> <span class='hs-varid'>mask_</span> <span class='hs-varop'>$</span> <span class='hs-keyword'>do</span>
<a name="line-12"></a> <span class='hs-varid'>stable_ref</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>newStablePtr</span> <span class='hs-varid'>a</span>
<a name="line-13"></a> <span class='hs-keyword'>let</span> <span class='hs-varid'>ref</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>castPtr</span> <span class='hs-layout'>(</span><span class='hs-varid'>castStablePtrToPtr</span> <span class='hs-varid'>stable_ref</span><span class='hs-layout'>)</span>
<a name="line-14"></a> <span class='hs-varid'>ref2</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>get_or_set</span> <span class='hs-varid'>ref</span>
<a name="line-15"></a> <span class='hs-keyword'>if</span> <span class='hs-varid'>ref</span><span class='hs-varop'>==</span><span class='hs-varid'>ref2</span>
<a name="line-16"></a> <span class='hs-keyword'>then</span> <span class='hs-varid'>return</span> <span class='hs-varid'>a</span>
<a name="line-17"></a> <span class='hs-keyword'>else</span> <span class='hs-keyword'>do</span> <span class='hs-varid'>freeStablePtr</span> <span class='hs-varid'>stable_ref</span>
<a name="line-18"></a> <span class='hs-varid'>deRefStablePtr</span> <span class='hs-layout'>(</span><span class='hs-varid'>castPtrToStablePtr</span> <span class='hs-layout'>(</span><span class='hs-varid'>castPtr</span> <span class='hs-varid'>ref2</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-19"></a>
<a name="line-20"></a><a name="reportStackOverflow"></a><span class='hs-definition'>reportStackOverflow</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>IO</span> <span class='hs-conid'>()</span>
<a name="line-21"></a><span class='hs-definition'>reportStackOverflow</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>callStackOverflowHook</span>
<a name="line-22"></a>
<a name="line-23"></a><a name="reportError"></a><span class='hs-definition'>reportError</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>SomeException</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>IO</span> <span class='hs-conid'>()</span>
<a name="line-24"></a><span class='hs-definition'>reportError</span> <span class='hs-varid'>ex</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>
<a name="line-25"></a> <span class='hs-varid'>handler</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>getUncaughtExceptionHandler</span>
<a name="line-26"></a> <span class='hs-varid'>handler</span> <span class='hs-varid'>ex</span>
<a name="line-27"></a>
<a name="line-28"></a><span class='hs-comment'>-- SUP: Are the hooks allowed to re-enter Haskell land? If so, remove</span>
<a name="line-29"></a><span class='hs-comment'>-- the unsafe below.</span>
<a name="line-30"></a><span class='hs-keyword'>foreign</span> <span class='hs-keyword'>import</span> <span class='hs-keyword'>ccall</span> <span class='hs-keyword'>unsafe</span> <span class='hs-str'>"stackOverflow"</span>
<a name="line-31"></a> <span class='hs-varid'>callStackOverflowHook</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>IO</span> <span class='hs-conid'>()</span>
<a name="line-32"></a>
<a name="line-33"></a><a name="uncaughtExceptionHandler"></a><span class='hs-comment'>{-# NOINLINE uncaughtExceptionHandler #-}</span>
<a name="line-34"></a><span class='hs-definition'>uncaughtExceptionHandler</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>IORef</span> <span class='hs-layout'>(</span><span class='hs-conid'>SomeException</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>IO</span> <span class='hs-conid'>()</span><span class='hs-layout'>)</span>
<a name="line-35"></a><span class='hs-definition'>uncaughtExceptionHandler</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>unsafePerformIO</span> <span class='hs-layout'>(</span><span class='hs-varid'>newIORef</span> <span class='hs-varid'>defaultHandler</span><span class='hs-layout'>)</span>
<a name="line-36"></a> <span class='hs-keyword'>where</span>
<a name="line-37"></a> <span class='hs-varid'>defaultHandler</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>SomeException</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>IO</span> <span class='hs-conid'>()</span>
<a name="line-38"></a> <span class='hs-varid'>defaultHandler</span> <span class='hs-varid'>se</span><span class='hs-keyglyph'>@</span><span class='hs-layout'>(</span><span class='hs-conid'>SomeException</span> <span class='hs-varid'>ex</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>
<a name="line-39"></a> <span class='hs-layout'>(</span><span class='hs-varid'>hFlush</span> <span class='hs-varid'>stdout</span><span class='hs-layout'>)</span> <span class='hs-varop'>`catchAny`</span> <span class='hs-layout'>(</span><span class='hs-keyglyph'>\</span> <span class='hs-keyword'>_</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>return</span> <span class='hs-conid'>()</span><span class='hs-layout'>)</span>
<a name="line-40"></a> <span class='hs-keyword'>let</span> <span class='hs-varid'>msg</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>case</span> <span class='hs-varid'>cast</span> <span class='hs-varid'>ex</span> <span class='hs-keyword'>of</span>
<a name="line-41"></a> <span class='hs-conid'>Just</span> <span class='hs-conid'>Deadlock</span> <span class='hs-keyglyph'>-></span> <span class='hs-str'>"no threads to run: infinite loop or deadlock?"</span>
<a name="line-42"></a> <span class='hs-keyword'>_</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyword'>case</span> <span class='hs-varid'>cast</span> <span class='hs-varid'>ex</span> <span class='hs-keyword'>of</span>
<a name="line-43"></a> <span class='hs-conid'>Just</span> <span class='hs-layout'>(</span><span class='hs-conid'>ErrorCall</span> <span class='hs-varid'>s</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>s</span>
<a name="line-44"></a> <span class='hs-keyword'>_</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>showsPrec</span> <span class='hs-num'>0</span> <span class='hs-varid'>se</span> <span class='hs-str'>""</span>
<a name="line-45"></a> <span class='hs-varid'>withCString</span> <span class='hs-str'>"%s"</span> <span class='hs-varop'>$</span> <span class='hs-keyglyph'>\</span><span class='hs-varid'>cfmt</span> <span class='hs-keyglyph'>-></span>
<a name="line-46"></a> <span class='hs-varid'>withCString</span> <span class='hs-varid'>msg</span> <span class='hs-varop'>$</span> <span class='hs-keyglyph'>\</span><span class='hs-varid'>cmsg</span> <span class='hs-keyglyph'>-></span>
<a name="line-47"></a> <span class='hs-varid'>errorBelch</span> <span class='hs-varid'>cfmt</span> <span class='hs-varid'>cmsg</span>
<a name="line-48"></a>
<a name="line-49"></a><span class='hs-comment'>-- don't use errorBelch() directly, because we cannot call varargs functions</span>
<a name="line-50"></a><span class='hs-comment'>-- using the FFI.</span>
<a name="line-51"></a><span class='hs-keyword'>foreign</span> <span class='hs-keyword'>import</span> <span class='hs-keyword'>ccall</span> <span class='hs-keyword'>unsafe</span> <span class='hs-str'>"HsBase.h errorBelch2"</span>
<a name="line-52"></a> <span class='hs-varid'>errorBelch</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>CString</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>CString</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>IO</span> <span class='hs-conid'>()</span>
<a name="line-53"></a>
<a name="line-54"></a><a name="setUncaughtExceptionHandler"></a><span class='hs-definition'>setUncaughtExceptionHandler</span> <span class='hs-keyglyph'>::</span> <span class='hs-layout'>(</span><span class='hs-conid'>SomeException</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>IO</span> <span class='hs-conid'>()</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>IO</span> <span class='hs-conid'>()</span>
<a name="line-55"></a><span class='hs-definition'>setUncaughtExceptionHandler</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>writeIORef</span> <span class='hs-varid'>uncaughtExceptionHandler</span>
<a name="line-56"></a>
<a name="line-57"></a><a name="getUncaughtExceptionHandler"></a><span class='hs-definition'>getUncaughtExceptionHandler</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>IO</span> <span class='hs-layout'>(</span><span class='hs-conid'>SomeException</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>IO</span> <span class='hs-conid'>()</span><span class='hs-layout'>)</span>
<a name="line-58"></a><span class='hs-definition'>getUncaughtExceptionHandler</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>readIORef</span> <span class='hs-varid'>uncaughtExceptionHandler</span>
<a name="line-59"></a>
</pre>\end{code}
</body>
</html>
