summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--libraries/base/GHC/Conc/Sync.hs3
-rw-r--r--libraries/base/GHC/Conc/Sync.hs-boot2
-rw-r--r--libraries/base/GHC/Event/Windows.hsc15
-rw-r--r--libraries/base/GHC/Event/Windows/FFI.hsc27
-rw-r--r--libraries/base/tests/T18382/all.T1
-rw-r--r--libraries/ghc-heap/GHC/Exts/Heap/Closures.hs1
-rw-r--r--libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingDisabled.hsc2
-rw-r--r--libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingEnabled.hsc2
-rw-r--r--rts/PrimOps.cmm6
-rw-r--r--rts/RaiseAsync.c7
-rw-r--r--rts/Schedule.c31
-rw-r--r--rts/Threads.c3
-rw-r--r--rts/Trace.c1
-rw-r--r--rts/TraverseHeap.c1
-rw-r--r--rts/include/rts/Constants.h8
-rw-r--r--rts/include/rts/storage/TSO.h1
-rw-r--r--rts/sm/Compact.c1
-rw-r--r--rts/sm/Sanity.c1
-rw-r--r--rts/sm/Scav.c1
-rw-r--r--rts/win32/AsyncWinIO.c9
20 files changed, 31 insertions, 92 deletions
diff --git a/libraries/base/GHC/Conc/Sync.hs b/libraries/base/GHC/Conc/Sync.hs
index d5fb4868df..99df92daed 100644
--- a/libraries/base/GHC/Conc/Sync.hs
+++ b/libraries/base/GHC/Conc/Sync.hs
@@ -544,8 +544,6 @@ data BlockReason
-- ^blocked in 'retry' in an STM transaction
| BlockedOnForeignCall
-- ^currently in a foreign call
- | BlockedOnIOCompletion
- -- ^currently blocked on an I/O Completion port
| BlockedOnOther
-- ^blocked on some other resource. Without @-threaded@,
-- I\/O and 'Control.Concurrent.threadDelay' show up as
@@ -584,7 +582,6 @@ threadStatus (ThreadId t) = IO $ \s ->
mk_stat 11 = ThreadBlocked BlockedOnForeignCall
mk_stat 12 = ThreadBlocked BlockedOnException
mk_stat 14 = ThreadBlocked BlockedOnMVar -- possibly: BlockedOnMVarRead
- mk_stat 15 = ThreadBlocked BlockedOnIOCompletion
-- NB. these are hardcoded in rts/PrimOps.cmm
mk_stat 16 = ThreadFinished
mk_stat 17 = ThreadDied
diff --git a/libraries/base/GHC/Conc/Sync.hs-boot b/libraries/base/GHC/Conc/Sync.hs-boot
index 07b4ef05ab..4a8e4192c2 100644
--- a/libraries/base/GHC/Conc/Sync.hs-boot
+++ b/libraries/base/GHC/Conc/Sync.hs-boot
@@ -49,8 +49,6 @@ data BlockReason
-- ^blocked in 'retry' in an STM transaction
| BlockedOnForeignCall
-- ^currently in a foreign call
- | BlockedOnIOCompletion
- -- ^currently blocked on an I/O Completion port
| BlockedOnOther
-- ^blocked on some other resource. Without @-threaded@,
-- I\/O and 'threadDelay' show up as 'BlockedOnOther', with @-threaded@
diff --git a/libraries/base/GHC/Event/Windows.hsc b/libraries/base/GHC/Event/Windows.hsc
index cc6bbaa927..973f25722b 100644
--- a/libraries/base/GHC/Event/Windows.hsc
+++ b/libraries/base/GHC/Event/Windows.hsc
@@ -542,18 +542,19 @@ withOverlappedEx mgr fname h async offset startCB completionCB = do
signalThrow ex = failIfFalse_ (dbgMsg "signalThrow") $
writeIOPort signal (IOFailed ex)
mask_ $ do
- let completionCB' e b = completionCB e b >>= \result ->
- case result of
- IOSuccess val -> signalReturn val
- IOFailed err -> signalThrow err
- let callbackData = CompletionData h completionCB'
+ let completionCB' e b = do
+ result <- completionCB e b
+ case result of
+ IOSuccess val -> signalReturn val
+ IOFailed err -> signalThrow err
+
-- Note [Memory Management]
-- These callback data and especially the overlapped structs have to keep
-- alive throughout the entire lifetime of the requests. Since this
-- function will block until done so it can call completionCB at the end
-- we can safely use dynamic memory management here and so reduce the
-- possibility of memory errors.
- withRequest async offset callbackData $ \hs_lpol cdData -> do
+ withRequest async offset h completionCB' $ \hs_lpol cdData -> do
let ptr_lpol = hs_lpol `plusPtr` cdOffset
let lpol = castPtr hs_lpol
-- We need to add the payload before calling startCBResult, the reason being
@@ -1066,7 +1067,7 @@ processCompletion Manager{..} n delay = do
when (oldDataPtr /= nullPtr && oldDataPtr /= castPtr nullReq) $
do debugIO $ "exchanged: " ++ show oldDataPtr
payload <- peek oldDataPtr :: IO CompletionData
- let !cb = cdCallback payload
+ cb <- deRefStablePtr (cdCallback payload)
reqs <- removeRequest
debugIO $ "-1.. " ++ show reqs ++ " requests queued."
status <- FFI.overlappedIOStatus (lpOverlapped oe)
diff --git a/libraries/base/GHC/Event/Windows/FFI.hsc b/libraries/base/GHC/Event/Windows/FFI.hsc
index c9c96d9d1e..c087f94eb1 100644
--- a/libraries/base/GHC/Event/Windows/FFI.hsc
+++ b/libraries/base/GHC/Event/Windows/FFI.hsc
@@ -231,14 +231,6 @@ type CompletionCallback a = ErrCode -- ^ 0 indicates success
-- | Callback type that will be called when an I/O operation completes.
type IOCallback = CompletionCallback ()
--- | Wrap the IOCallback type into a FunPtr.
-foreign import ccall "wrapper"
- wrapIOCallback :: IOCallback -> IO (FunPtr IOCallback)
-
--- | Unwrap a FunPtr IOCallback to a normal Haskell function.
-foreign import ccall "dynamic"
- mkIOCallback :: FunPtr IOCallback -> IOCallback
-
-- | Structure that the I/O manager uses to associate callbacks with
-- additional payload such as their OVERLAPPED structure and Win32 handle
-- etc. *Must* be kept in sync with that in `winio_structs.h` or horrible things
@@ -247,7 +239,7 @@ foreign import ccall "dynamic"
-- We keep the handle around for the benefit of ghc-external libraries making
-- use of the manager.
data CompletionData = CompletionData { cdHandle :: !HANDLE
- , cdCallback :: !IOCallback
+ , cdCallback :: !(StablePtr IOCallback)
}
instance Storable CompletionData where
@@ -255,14 +247,13 @@ instance Storable CompletionData where
alignment _ = #{alignment CompletionData}
peek ptr = do
- cdCallback <- mkIOCallback `fmap` #{peek CompletionData, cdCallback} ptr
+ cdCallback <- #{peek CompletionData, cdCallback} ptr
cdHandle <- #{peek CompletionData, cdHandle} ptr
let !cd = CompletionData{..}
return cd
poke ptr CompletionData{..} = do
- cb <- wrapIOCallback cdCallback
- #{poke CompletionData, cdCallback} ptr cb
+ #{poke CompletionData, cdCallback} ptr cdCallback
#{poke CompletionData, cdHandle} ptr cdHandle
------------------------------------------------------------------------
@@ -402,10 +393,10 @@ pokeEventOverlapped lpol event = do
-- the native OS Handle not the Haskell one. i.e. remote-iserv.
-- See [Note AsyncHandles]
-withRequest :: Bool -> Word64 -> CompletionData
+withRequest :: Bool -> Word64 -> HANDLE -> IOCallback
-> (Ptr HASKELL_OVERLAPPED -> Ptr CompletionData -> IO a)
-> IO a
-withRequest async offset cbData f =
+withRequest async offset hdl cb f = do
-- Create the completion record and store it.
-- We only need the record when we enqueue a request, however if we
-- delay creating it then we will run into a race condition where the
@@ -417,7 +408,10 @@ withRequest async offset cbData f =
--
-- Todo: Use a memory pool for this so we don't have to hit malloc every
-- time. This would allow us to scale better.
- allocaBytes #{size HASKELL_OVERLAPPED} $ \hs_lpol ->
+ cb_sptr <- newStablePtr cb
+ let cbData :: CompletionData
+ cbData = CompletionData hdl cb_sptr
+ r <- allocaBytes #{size HASKELL_OVERLAPPED} $ \hs_lpol ->
with cbData $ \cdData -> do
zeroOverlapped hs_lpol
let lpol = castPtr hs_lpol
@@ -436,6 +430,9 @@ withRequest async offset cbData f =
failIfFalse_ "withRequest (free)" $ c_CloseHandle event
return res
+ freeStablePtr cb_sptr
+ return r
+
-- | Create an event object for use when the HANDLE isn't asynchronous
foreign import WINDOWS_CCONV unsafe "windows.h CreateEventW"
diff --git a/libraries/base/tests/T18382/all.T b/libraries/base/tests/T18382/all.T
index f58231688d..4e65d556ce 100644
--- a/libraries/base/tests/T18382/all.T
+++ b/libraries/base/tests/T18382/all.T
@@ -1,7 +1,6 @@
test('T18382',
[unless(opsys('mingw32'), skip),
extra_run_opts('+RTS --io-manager=native -RTS'),
- expect_broken(18382),
],
compile_and_run,
[''])
diff --git a/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs b/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
index e15ae7008b..075e2a5b17 100644
--- a/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
+++ b/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
@@ -387,7 +387,6 @@ data WhyBlocked
| BlockedOnCCall_Interruptible
| BlockedOnMsgThrowTo
| ThreadMigrating
- | BlockedOnIOCompletion
| WhyBlockedUnknownValue Word16 -- ^ Please report this as a bug
deriving (Eq, Show, Generic, Ord)
diff --git a/libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingDisabled.hsc b/libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingDisabled.hsc
index 69c88db57d..48f99d2fcb 100644
--- a/libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingDisabled.hsc
+++ b/libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingDisabled.hsc
@@ -77,7 +77,7 @@ parseWhyBlocked w = case w of
(#const BlockedOnCCall_Interruptible) -> BlockedOnCCall_Interruptible
(#const BlockedOnMsgThrowTo) -> BlockedOnMsgThrowTo
(#const ThreadMigrating) -> ThreadMigrating
-#if __GLASGOW_HASKELL__ >= 811
+#if __GLASGOW_HASKELL__ >= 811 && __GLASGOW_HASKELL__ < 903
(#const BlockedOnIOCompletion) -> BlockedOnIOCompletion
#endif
_ -> WhyBlockedUnknownValue w
diff --git a/libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingEnabled.hsc b/libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingEnabled.hsc
index 17bf3c8334..e9d106d46a 100644
--- a/libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingEnabled.hsc
+++ b/libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingEnabled.hsc
@@ -77,7 +77,7 @@ parseWhyBlocked w = case w of
(#const BlockedOnCCall_Interruptible) -> BlockedOnCCall_Interruptible
(#const BlockedOnMsgThrowTo) -> BlockedOnMsgThrowTo
(#const ThreadMigrating) -> ThreadMigrating
-#if __GLASGOW_HASKELL__ >= 811
+#if __GLASGOW_HASKELL__ >= 811 && __GLASGOW_HASKELL__ < 903
(#const BlockedOnIOCompletion) -> BlockedOnIOCompletion
#endif
_ -> WhyBlockedUnknownValue w
diff --git a/rts/PrimOps.cmm b/rts/PrimOps.cmm
index edbd435702..15f9e949b0 100644
--- a/rts/PrimOps.cmm
+++ b/rts/PrimOps.cmm
@@ -2222,7 +2222,7 @@ stg_readIOPortzh ( P_ ioport /* :: IOPort a */ )
StgMVar_head(ioport) = q;
StgTSO__link(CurrentTSO) = q;
StgTSO_block_info(CurrentTSO) = ioport;
- StgTSO_why_blocked(CurrentTSO) = BlockedOnIOCompletion::I16;
+ StgTSO_why_blocked(CurrentTSO) = BlockedOnMVar::I16;
//Unlocks the closure as well
jump stg_block_readmvar(ioport);
@@ -2328,8 +2328,8 @@ loop:
// at this point.
//Either there was no reader queued, or he must have been
- //blocked on BlockedOnIOCompletion
- ASSERT(why_blocked == BlockedOnIOCompletion);
+ //blocked on BlockedOnMVar
+ ASSERT(why_blocked == BlockedOnMVar);
unlockClosure(ioport, info);
return (1);
diff --git a/rts/RaiseAsync.c b/rts/RaiseAsync.c
index a0719024b4..39f39a22b4 100644
--- a/rts/RaiseAsync.c
+++ b/rts/RaiseAsync.c
@@ -175,7 +175,7 @@ throwToSelf (Capability *cap, StgTSO *tso, StgClosure *exception)
- or it is masking exceptions (TSO_BLOCKEX)
Currently, if the target is BlockedOnMVar, BlockedOnSTM,
- BlockedOnIOCompletion or BlockedOnBlackHole then we acquire ownership of the
+ or BlockedOnBlackHole then we acquire ownership of the
TSO by locking its parent container (e.g. the MVar) and then raise the
exception. We might change these cases to be more message-passing-like in
the future.
@@ -344,7 +344,6 @@ check_target:
case BlockedOnMVar:
case BlockedOnMVarRead:
- case BlockedOnIOCompletion:
{
/*
To establish ownership of this TSO, we need to acquire a
@@ -370,8 +369,7 @@ check_target:
// we have the MVar, let's check whether the thread
// is still blocked on the same MVar.
if ((target->why_blocked != BlockedOnMVar
- && target->why_blocked != BlockedOnMVarRead
- && target->why_blocked != BlockedOnIOCompletion)
+ && target->why_blocked != BlockedOnMVarRead)
|| (StgMVar *)target->block_info.closure != mvar) {
unlockClosure((StgClosure *)mvar, info);
goto retry;
@@ -684,7 +682,6 @@ removeFromQueues(Capability *cap, StgTSO *tso)
case BlockedOnMVar:
case BlockedOnMVarRead:
- case BlockedOnIOCompletion:
removeFromMVarBlockedQueue(tso);
goto done;
diff --git a/rts/Schedule.c b/rts/Schedule.c
index 4fe18fa769..b9b15811c9 100644
--- a/rts/Schedule.c
+++ b/rts/Schedule.c
@@ -942,7 +942,6 @@ scheduleDetectDeadlock (Capability **pcap, Task *task)
*/
if (SEQ_CST_LOAD(&recent_activity) != ACTIVITY_INACTIVE) return;
#endif
- if (task->incall->tso && task->incall->tso->why_blocked == BlockedOnIOCompletion) return;
debugTrace(DEBUG_sched, "deadlocked, forcing major GC...");
@@ -980,31 +979,6 @@ scheduleDetectDeadlock (Capability **pcap, Task *task)
return;
}
#endif
-
-#if !defined(THREADED_RTS)
- /* Probably a real deadlock. Send the current main thread the
- * Deadlock exception.
- */
- if (task->incall->tso) {
- switch (task->incall->tso->why_blocked) {
- case BlockedOnSTM:
- case BlockedOnBlackHole:
- case BlockedOnMsgThrowTo:
- case BlockedOnMVar:
- case BlockedOnMVarRead:
- throwToSingleThreaded(cap, task->incall->tso,
- (StgClosure *)nonTermination_closure);
- return;
- case BlockedOnIOCompletion:
- /* We're blocked waiting for an external I/O call, let's just
- chill for a bit. */
- return;
- default:
- barf("deadlock: main thread blocked in a strange way");
- }
- }
- return;
-#endif
}
}
@@ -3218,11 +3192,6 @@ resurrectThreads (StgTSO *threads)
throwToSingleThreaded(cap, tso,
(StgClosure *)blockedIndefinitelyOnSTM_closure);
break;
- case BlockedOnIOCompletion:
- /* I/O Ports may not be reachable by the GC as they may be getting
- * notified by the RTS. As such this call should be treated as if
- * it is masking the exception. */
- continue;
case NotBlocked:
/* This might happen if the thread was blocked on a black hole
* belonging to a thread that we've just woken up (raiseAsync
diff --git a/rts/Threads.c b/rts/Threads.c
index b9f753234f..ab7af2e52c 100644
--- a/rts/Threads.c
+++ b/rts/Threads.c
@@ -286,7 +286,6 @@ tryWakeupThread (Capability *cap, StgTSO *tso)
switch (tso->why_blocked)
{
- case BlockedOnIOCompletion:
case BlockedOnMVar:
case BlockedOnMVarRead:
{
@@ -888,8 +887,6 @@ printThreadBlockage(StgTSO *tso)
case BlockedOnMVarRead:
debugBelch("is blocked on atomic MVar read @ %p", tso->block_info.closure);
break;
- case BlockedOnIOCompletion:
- debugBelch("is blocked on I/O Completion port @ %p", tso->block_info.closure);
break;
case BlockedOnBlackHole:
debugBelch("is blocked on a black hole %p",
diff --git a/rts/Trace.c b/rts/Trace.c
index 9edac3565e..f68a72cf2a 100644
--- a/rts/Trace.c
+++ b/rts/Trace.c
@@ -183,7 +183,6 @@ static char *thread_stop_reasons[] = {
[6 + BlockedOnSTM] = "blocked on STM",
[6 + BlockedOnDoProc] = "blocked on asyncDoProc",
[6 + BlockedOnCCall] = "blocked on a foreign call",
- [6 + BlockedOnIOCompletion] = "blocked on I/O Completion port",
[6 + BlockedOnCCall_Interruptible] = "blocked on a foreign call (interruptible)",
[6 + BlockedOnMsgThrowTo] = "blocked on throwTo",
[6 + ThreadMigrating] = "migrating"
diff --git a/rts/TraverseHeap.c b/rts/TraverseHeap.c
index 2285a93b6f..3b92bb9f98 100644
--- a/rts/TraverseHeap.c
+++ b/rts/TraverseHeap.c
@@ -1239,7 +1239,6 @@ inner_loop:
traversePushClosure(ts, (StgClosure *) tso->trec, c, sep, child_data);
if ( tso->why_blocked == BlockedOnMVar
|| tso->why_blocked == BlockedOnMVarRead
- || tso->why_blocked == BlockedOnIOCompletion
|| tso->why_blocked == BlockedOnBlackHole
|| tso->why_blocked == BlockedOnMsgThrowTo
) {
diff --git a/rts/include/rts/Constants.h b/rts/include/rts/Constants.h
index 9cbe47752e..b601999f88 100644
--- a/rts/include/rts/Constants.h
+++ b/rts/include/rts/Constants.h
@@ -256,13 +256,7 @@
by tryWakeupThread() */
#define ThreadMigrating 13
-/* Lightweight non-deadlock checked version of MVar. Used for the why_blocked
- field of a TSO. Threads blocked for this reason are not forcibly release by
- the GC, as we expect them to be unblocked in the future based on outstanding
- IO events. */
-#define BlockedOnIOCompletion 15
-
-/* Next number is 16. */
+/* Next number is 15. */
/*
* These constants are returned to the scheduler by a thread that has
diff --git a/rts/include/rts/storage/TSO.h b/rts/include/rts/storage/TSO.h
index fcbf7f7ab1..a6bd9e9087 100644
--- a/rts/include/rts/storage/TSO.h
+++ b/rts/include/rts/storage/TSO.h
@@ -304,7 +304,6 @@ void dirty_STACK (Capability *cap, StgStack *stack);
BlockedOnBlackHole MessageBlackHole * TSO->bq
BlockedOnMVar the MVAR the MVAR's queue
- BlockedOnIOCompletion the PortEVent the IOCP's queue
BlockedOnSTM END_TSO_QUEUE STM wait queue(s)
BlockedOnSTM STM_AWOKEN run queue
diff --git a/rts/sm/Compact.c b/rts/sm/Compact.c
index 43867343fc..3e71c30d35 100644
--- a/rts/sm/Compact.c
+++ b/rts/sm/Compact.c
@@ -461,7 +461,6 @@ thread_TSO (StgTSO *tso)
|| tso->why_blocked == BlockedOnMVarRead
|| tso->why_blocked == BlockedOnBlackHole
|| tso->why_blocked == BlockedOnMsgThrowTo
- || tso->why_blocked == BlockedOnIOCompletion
|| tso->why_blocked == NotBlocked
) {
thread_(&tso->block_info.closure);
diff --git a/rts/sm/Sanity.c b/rts/sm/Sanity.c
index 63ef9732dd..cf4e2dfea6 100644
--- a/rts/sm/Sanity.c
+++ b/rts/sm/Sanity.c
@@ -729,7 +729,6 @@ checkTSO(StgTSO *tso)
|| tso->why_blocked == BlockedOnMVarRead
|| tso->why_blocked == BlockedOnBlackHole
|| tso->why_blocked == BlockedOnMsgThrowTo
- || tso->why_blocked == BlockedOnIOCompletion
|| tso->why_blocked == NotBlocked
) {
ASSERT(LOOKS_LIKE_CLOSURE_PTR(tso->block_info.closure));
diff --git a/rts/sm/Scav.c b/rts/sm/Scav.c
index 9316f395a8..a36ebbb331 100644
--- a/rts/sm/Scav.c
+++ b/rts/sm/Scav.c
@@ -131,7 +131,6 @@ scavengeTSO (StgTSO *tso)
|| tso->why_blocked == BlockedOnMVarRead
|| tso->why_blocked == BlockedOnBlackHole
|| tso->why_blocked == BlockedOnMsgThrowTo
- || tso->why_blocked == BlockedOnIOCompletion
|| tso->why_blocked == NotBlocked
) {
evacuate(&tso->block_info.closure);
diff --git a/rts/win32/AsyncWinIO.c b/rts/win32/AsyncWinIO.c
index 5f61f815f3..fa397c343d 100644
--- a/rts/win32/AsyncWinIO.c
+++ b/rts/win32/AsyncWinIO.c
@@ -24,6 +24,7 @@
#include <stdio.h>
/* Note [Non-Threaded WINIO design]
+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Compared to Async MIO, Async WINIO does all of the heavy processing at the
Haskell side of things. The same code as the threaded WINIO is re-used for
the Non-threaded version. Of course since we are in a non-threaded rts we
@@ -122,10 +123,8 @@
See also Note [WINIO Manager design].
+ Note [Notifying the RTS/Haskell of completed events]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
- Note [Notifying the RTS/Haskell of completed events]
- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
The C side runner can't directly create a haskell thread.
With the current API of the haskell runtime this would be terrible
unsound. In particular the GC assumes no heap objects are generated,
@@ -137,10 +136,8 @@
ensures there is only one OS thread at a time making use of the haskell
heap.
+ Note [Non-Threaded IO Manager startup sequence]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
- Note [Non-Threaded IO Manager startup sequence]
- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
Under the new IO Manager we run a bit of initialization under
hs_init(). The first call into actual IO manager code is a
invocation of startupAsyncWinIO();
View Lorry Controller Status