From: sof Date: Fri, 22 Apr 2005 17:00:49 +0000 (+0000) Subject: [project @ 2005-04-22 17:00:48 by sof] X-Git-Tag: Initial_conversion_from_CVS_complete~695 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=ecb1a539308e65d242d963f00adc8c6c41e4972a;p=ghc-hetmet.git [project @ 2005-04-22 17:00:48 by sof] [mingw only] Better handling of I/O request abortions upon throwing an exception to a Haskell thread. As was, a thread blocked on an I/O request was simply unblocked, but its corresponding worker thread wasn't notified that the request had been abandoned. This manifested itself in GHCi upon Ctrl-C being hit at the prompt -- the worker thread blocked waiting for input on stdin prior to Ctrl-C would stick around even though its corresponding Haskell thread had been thrown an Interrupted exception. The upshot was that the worker would consume the next character typed in after Ctrl-C, but then just dropping it. Dealing with this turned out to be even more interesting due to Win32 aborting any console reads when Ctrl-C/Break events are delivered. The story could be improved upon (at the cost of portability) by making the Scheduler able to abort worker thread system calls; as is, requests are cooperatively abandoned. Maybe later. Also included are other minor tidyups to Ctrl-C handling under mingw. Merge to STABLE. --- diff --git a/ghc/compiler/ghci/InteractiveUI.hs b/ghc/compiler/ghci/InteractiveUI.hs index 275a2c1..6403293 100644 --- a/ghc/compiler/ghci/InteractiveUI.hs +++ b/ghc/compiler/ghci/InteractiveUI.hs @@ -261,7 +261,11 @@ runGHCi paths maybe_expr = do interactiveLoop is_tty show_prompt = do -- Ignore ^C exceptions caught here ghciHandleDyn (\e -> case e of - Interrupted -> ghciUnblock (interactiveLoop is_tty show_prompt) + Interrupted -> ghciUnblock ( +#if defined(mingw32_HOST_OS) + io (putStrLn "") >> +#endif + interactiveLoop is_tty show_prompt) _other -> return ()) $ do -- read commands from stdin diff --git a/ghc/includes/RtsExternal.h b/ghc/includes/RtsExternal.h index a988b18..919fe79 100644 --- a/ghc/includes/RtsExternal.h +++ b/ghc/includes/RtsExternal.h @@ -63,7 +63,8 @@ extern void* createAdjustor(int cconv, StgStablePtr hptr, StgFunPtr wptr, extern void freeHaskellFunctionPtr(void* ptr); #if defined(mingw32_HOST_OS) -extern int stg_InstallConsoleEvent(int action, StgStablePtr *handler); +extern int rts_InstallConsoleEvent ( int action, StgStablePtr *handler ); +extern void rts_ConsoleHandlerDone ( int ev ); #else extern int stg_sig_install (int, int, StgStablePtr *, void *); #endif diff --git a/ghc/includes/TSO.h b/ghc/includes/TSO.h index ce1d29c..9824888 100644 --- a/ghc/includes/TSO.h +++ b/ghc/includes/TSO.h @@ -85,7 +85,7 @@ typedef StgWord32 StgThreadID; typedef unsigned int StgThreadReturnCode; #if defined(mingw32_HOST_OS) -/* results from an async I/O request + it's ID. */ +/* results from an async I/O request + its request ID. */ typedef struct { unsigned int reqID; int len; @@ -98,7 +98,7 @@ typedef union { struct StgTSO_ *tso; StgInt fd; /* StgInt instead of int, so that it's the same size as the ptrs */ #if defined(mingw32_HOST_OS) - StgAsyncIOResult* async_result; + StgAsyncIOResult *async_result; #endif StgWord target; } StgTSOBlockInfo; diff --git a/ghc/rts/Linker.c b/ghc/rts/Linker.c index b0c3b56..3e42c0d 100644 --- a/ghc/rts/Linker.c +++ b/ghc/rts/Linker.c @@ -296,7 +296,8 @@ typedef struct _RtsSymbolVal { SymX(log) \ SymX(sqrt) \ SymX(memcpy) \ - SymX(stg_InstallConsoleEvent) \ + SymX(rts_InstallConsoleEvent) \ + SymX(rts_ConsoleHandlerDone) \ Sym(mktime) \ Sym(_imp___timezone) \ Sym(_imp___tzname) \ @@ -1981,7 +1982,7 @@ ocGetNames_PEi386 ( ObjectCode* oc ) && 0 != strcmp(".stab", sectab_i->Name) && 0 != strcmp(".stabstr", sectab_i->Name) ) { - errorBelch("Unknown PEi386 section name `%s'", sectab_i->Name); + errorBelch("Unknown PEi386 section name `%s' (while processing: %s)", sectab_i->Name, oc->fileName); return 0; } diff --git a/ghc/rts/Schedule.c b/ghc/rts/Schedule.c index 9e3e45f..d1cdcfc 100644 --- a/ghc/rts/Schedule.c +++ b/ghc/rts/Schedule.c @@ -3343,6 +3343,12 @@ unblockThread(StgTSO *tso) blocked_queue_tl = (StgTSO *)prev; } } +#if defined(mingw32_HOST_OS) + /* (Cooperatively) signal that the worker thread should abort + * the request. + */ + abandonWorkRequest(tso->block_info.async_result->reqID); +#endif goto done; } } @@ -3477,6 +3483,12 @@ unblockThread(StgTSO *tso) blocked_queue_tl = prev; } } +#if defined(mingw32_HOST_OS) + /* (Cooperatively) signal that the worker thread should abort + * the request. + */ + abandonWorkRequest(tso->block_info.async_result->reqID); +#endif goto done; } } diff --git a/ghc/rts/win32/AsyncIO.c b/ghc/rts/win32/AsyncIO.c index a0e03cb..83797c4 100644 --- a/ghc/rts/win32/AsyncIO.c +++ b/ghc/rts/win32/AsyncIO.c @@ -200,9 +200,11 @@ start: DWORD dwRes = WaitForMultipleObjects(2, wait_handles, FALSE, INFINITE); switch (dwRes) { case WAIT_OBJECT_0: + /* a request was completed */ break; case WAIT_OBJECT_0 + 1: case WAIT_TIMEOUT: + /* timeout (unlikely) or told to abandon waiting */ return 0; case WAIT_FAILED: { DWORD dw = GetLastError(); diff --git a/ghc/rts/win32/ConsoleHandler.c b/ghc/rts/win32/ConsoleHandler.c index a6a53a0..c68dc1d 100644 --- a/ghc/rts/win32/ConsoleHandler.c +++ b/ghc/rts/win32/ConsoleHandler.c @@ -19,6 +19,8 @@ static BOOL WINAPI generic_handler(DWORD dwCtrlType); static rtsBool deliver_event = rtsTrue; static StgInt console_handler = STG_SIG_DFL; +static HANDLE hConsoleEvent = INVALID_HANDLE_VALUE; + #define N_PENDING_EVENTS 16 StgInt stg_pending_events = 0; /* number of undelivered events */ DWORD stg_pending_buf[N_PENDING_EVENTS]; /* their associated event numbers. */ @@ -33,6 +35,13 @@ initUserSignals(void) { stg_pending_events = 0; console_handler = STG_SIG_DFL; + if (hConsoleEvent == INVALID_HANDLE_VALUE) { + hConsoleEvent = + CreateEvent ( NULL, /* default security attributes */ + FALSE, /* auto-reset event */ + FALSE, /* initially non-signalled */ + NULL); /* no name */ + } return; } @@ -216,12 +225,12 @@ static BOOL WINAPI generic_handler(DWORD dwCtrlType) /* - * Function: stg_InstallConsoleEvent() + * Function: rts_InstallConsoleEvent() * * Install/remove a console event handler. */ int -stg_InstallConsoleEvent(int action, StgStablePtr *handler) +rts_InstallConsoleEvent(int action, StgStablePtr *handler) { StgInt previous_hdlr = console_handler; @@ -257,3 +266,46 @@ stg_InstallConsoleEvent(int action, StgStablePtr *handler) return STG_SIG_HAN; } } + +/* + * Function: rts_HandledConsoleEvent() + * + * Signal that a Haskell console event handler has completed its run. + * The explicit notification that a Haskell handler has completed is + * required to better handle the delivery of Ctrl-C/Break events whilst + * an async worker thread is handling a read request on stdin. The + * Win32 console implementation will abort such a read request when Ctrl-C + * is delivered. That leaves the worker thread in a bind: should it + * abandon the request (the Haskell thread reading from stdin has been + * thrown an exception to signal the delivery of Ctrl-C & hence have + * aborted the I/O request) or simply ignore the aborted read and retry? + * (the Haskell thread reading from stdin isn't concerned with the + * delivery and handling of Ctrl-C.) With both scenarios being + * possible, the worker thread needs to be told -- that is, did the + * console event handler cause the IO request to be abandoned? + * + */ +void +rts_ConsoleHandlerDone(int ev) +{ + if ( (DWORD)ev == CTRL_BREAK_EVENT || + (DWORD)ev == CTRL_C_EVENT ) { + /* only these two cause stdin system calls to abort.. */ + SetEvent(hConsoleEvent); /* event is auto-reset */ + } +} + +/* + * Function: rts_waitConsoleHandlerCompletion() + * + * Esoteric entry point used by worker thread that got woken + * up as part Ctrl-C delivery. + */ +int +rts_waitConsoleHandlerCompletion() +{ + /* As long as the worker doesn't need to do a multiple wait, + * let's keep this HANDLE private to this 'module'. + */ + return (WaitForSingleObject(hConsoleEvent, INFINITE) == WAIT_OBJECT_0); +} diff --git a/ghc/rts/win32/ConsoleHandler.h b/ghc/rts/win32/ConsoleHandler.h index 928b675..f64b320 100644 --- a/ghc/rts/win32/ConsoleHandler.h +++ b/ghc/rts/win32/ConsoleHandler.h @@ -99,4 +99,12 @@ extern void markSignalHandlers (evac_fn evac); */ extern void handleSignalsInThisThread(void); +/* + * Function: rts_waitConsoleHandlerCompletion() + * + * Esoteric entry point used by worker thread that got woken + * up as part Ctrl-C delivery. + */ +extern int rts_waitConsoleHandlerCompletion(void); + #endif /* __CONSOLEHANDLER_H__ */ diff --git a/ghc/rts/win32/IOManager.c b/ghc/rts/win32/IOManager.c index 60f6aa8..a67c350 100644 --- a/ghc/rts/win32/IOManager.c +++ b/ghc/rts/win32/IOManager.c @@ -4,8 +4,10 @@ * * (c) sof, 2002-2003. */ +#include "Rts.h" #include "IOManager.h" #include "WorkQueue.h" +#include "ConsoleHandler.h" #include #include #include @@ -23,11 +25,17 @@ typedef struct IOManagerState { int workersIdle; HANDLE hExitEvent; unsigned int requestID; + /* fields for keeping track of active WorkItems */ + CritSection active_work_lock; + WorkItem* active_work_items; } IOManagerState; /* ToDo: wrap up this state via a IOManager handle instead? */ static IOManagerState* ioMan; +static void RegisterWorkItem ( IOManagerState* iom, WorkItem* wi); +static void DeregisterWorkItem( IOManagerState* iom, WorkItem* wi); + /* * The routine executed by each worker thread. */ @@ -86,6 +94,8 @@ IOWorkerProc(PVOID param) if ( rc == (WAIT_OBJECT_0 + 1) ) { /* work item available, fetch it. */ if (FetchWork(pq,(void**)&work)) { + work->abandonOp = 0; + RegisterWorkItem(iom,work); if ( work->workKind & WORKER_READ ) { if ( work->workKind & WORKER_FOR_SOCKET ) { len = recv(work->workData.ioData.fd, @@ -96,14 +106,11 @@ IOWorkerProc(PVOID param) errCode = WSAGetLastError(); } } else { - DWORD dw; - while (1) { /* Do the read(), with extra-special handling for Ctrl+C */ len = read(work->workData.ioData.fd, work->workData.ioData.buf, work->workData.ioData.len); - dw = GetLastError(); if ( len == 0 && work->workData.ioData.len != 0 ) { /* Given the following scenario: * - a console handler has been registered that handles Ctrl+C @@ -116,28 +123,33 @@ IOWorkerProc(PVOID param) * The OS will invoke the console handler (in a separate OS thread), * and the above read() (i.e., under the hood, a ReadFile() op) returns * 0, with the error set to ERROR_OPERATION_ABORTED. We don't - * want to percolate this non-EOF condition too far back up, but ignore - * it. - * - * However, we do want to give the RTS an opportunity to deliver the - * console event. Take care of this in the low-level console handler - * in ConsoleHandler.c which wakes up the RTS thread that's blocked - * waiting for I/O results from this worker (and possibly others). - * It won't see any I/O, but notices and dispatches the queued up - * signals/console events while in the Scheduler. - * - * The original, and way hackier scheme, was to have the worker - * return a special return code representing aborted-due-to-ctrl-C-on-stdin, - * which GHC.Conc.asyncRead would look out for and retry the I/O - * call if encountered. + * want to percolate this error condition back to the Haskell user. + * Do this by waiting for the completion of the Haskell console handler. + * If upon completion of the console handler routine, the Haskell thread + * that issued the request is found to have been thrown an exception, + * the worker abandons the request (since that's what the Haskell thread + * has done.) If the Haskell thread hasn't been interrupted, the worker + * retries the read request as if nothing happened. */ - if ( dw == ERROR_OPERATION_ABORTED ) { - /* Only do the retry when dealing with the standard input handle. */ + if ( (GetLastError()) == ERROR_OPERATION_ABORTED ) { + /* For now, only abort when dealing with the standard input handle. + * i.e., for all others, an error is raised. + */ HANDLE h = (HANDLE)GetStdHandle(STD_INPUT_HANDLE); if ( _get_osfhandle(work->workData.ioData.fd) == (long)h ) { - Sleep(0); - } else { - break; + if (rts_waitConsoleHandlerCompletion()) { + /* If the Scheduler has set work->abandonOp, the Haskell thread has + * been thrown an exception (=> the worker must abandon this request.) + * We test for this below before invoking the on-completion routine. + */ + if (work->abandonOp) { + break; + } else { + continue; + } + } + } else { + break; /* Treat it like an error */ } } else { break; @@ -193,19 +205,22 @@ IOWorkerProc(PVOID param) fflush(stderr); continue; } - work->onCompletion(work->requestID, - fd, - len, - complData, - errCode); + if (!work->abandonOp) { + work->onCompletion(work->requestID, + fd, + len, + complData, + errCode); + } /* Free the WorkItem */ + DeregisterWorkItem(iom,work); free(work); } else { fprintf(stderr, "unable to fetch work; fatal.\n"); fflush(stderr); return 1; } } else { - fprintf(stderr, "waiting failed; fatal.\n"); fflush(stderr); + fprintf(stderr, "waiting failed (%lu); fatal.\n", rc); fflush(stderr); return 1; } } @@ -256,6 +271,8 @@ StartIOManager(void) ioMan->workersIdle = 0; ioMan->queueSize = 0; ioMan->requestID = 1; + InitializeCriticalSection(&ioMan->active_work_lock); + ioMan->active_work_items = NULL; return TRUE; } @@ -358,6 +375,7 @@ AddIORequest ( int fd, wItem->workData.ioData.fd = fd; wItem->workData.ioData.len = len; wItem->workData.ioData.buf = buffer; + wItem->link = NULL; wItem->onCompletion = onCompletion; wItem->requestID = reqID; @@ -384,6 +402,7 @@ AddDelayRequest ( unsigned int msecs, wItem->workData.delayData.msecs = msecs; wItem->onCompletion = onCompletion; wItem->requestID = reqID; + wItem->link = NULL; return depositWorkItem(reqID, wItem); } @@ -408,6 +427,8 @@ AddProcRequest ( void* proc, wItem->workData.procData.param = param; wItem->onCompletion = onCompletion; wItem->requestID = reqID; + wItem->abandonOp = 0; + wItem->link = NULL; return depositWorkItem(reqID, wItem); } @@ -421,3 +442,69 @@ void ShutdownIOManager ( void ) // free(ioMan); // ioMan = NULL; } + +/* Keep track of WorkItems currently being serviced. */ +static +void +RegisterWorkItem(IOManagerState* ioMan, + WorkItem* wi) +{ + EnterCriticalSection(&ioMan->active_work_lock); + wi->link = ioMan->active_work_items; + ioMan->active_work_items = wi; + LeaveCriticalSection(&ioMan->active_work_lock); +} + +static +void +DeregisterWorkItem(IOManagerState* ioMan, + WorkItem* wi) +{ + WorkItem *ptr, *prev; + + EnterCriticalSection(&ioMan->active_work_lock); + for(prev=NULL,ptr=ioMan->active_work_items;ptr;prev=ptr,ptr=ptr->link) { + if (wi->requestID == ptr->requestID) { + if (prev==NULL) { + ioMan->active_work_items = ptr->link; + } else { + prev->link = ptr->link; + } + LeaveCriticalSection(&ioMan->active_work_lock); + return; + } + } + fprintf(stderr, "DeregisterWorkItem: unable to locate work item %d\n", wi->requestID); + LeaveCriticalSection(&ioMan->active_work_lock); +} + + +/* + * Function: abandonWorkRequest() + * + * Signal that a work request isn't of interest. Called by the Scheduler + * if a blocked Haskell thread has an exception thrown to it. + * + * Note: we're not aborting the system call that a worker might be blocked on + * here, just disabling the propagation of its result once its finished. We + * may have to go the whole hog here and switch to overlapped I/O so that we + * can abort blocked system calls. + */ +void +abandonWorkRequest ( int reqID ) +{ + WorkItem *ptr; + EnterCriticalSection(&ioMan->active_work_lock); + for(ptr=ioMan->active_work_items;ptr;ptr=ptr->link) { + if (ptr->requestID == (unsigned int)reqID ) { + ptr->abandonOp = 1; + LeaveCriticalSection(&ioMan->active_work_lock); + return; + } + } + /* Note: if the request ID isn't present, the worker will have + * finished sometime since awaitRequests() last drained the completed + * request table; i.e., not an error. + */ + LeaveCriticalSection(&ioMan->active_work_lock); +} diff --git a/ghc/rts/win32/IOManager.h b/ghc/rts/win32/IOManager.h index 686ea6c..4893e23 100644 --- a/ghc/rts/win32/IOManager.h +++ b/ghc/rts/win32/IOManager.h @@ -60,10 +60,12 @@ typedef union workData { } WorkData; typedef struct WorkItem { - unsigned int workKind; - WorkData workData; - unsigned int requestID; - CompletionProc onCompletion; + unsigned int workKind; + WorkData workData; + unsigned int requestID; + CompletionProc onCompletion; + unsigned int abandonOp; + struct WorkItem *link; } WorkItem; extern CompletionProc onComplete; @@ -103,4 +105,6 @@ extern int AddProcRequest ( void* proc, void* data, CompletionProc onCompletion); +extern void abandonWorkRequest ( int reqID ); + #endif /* __IOMANAGER_H__ */