Commit 528a7d2c authored by sewardj's avatar sewardj
Browse files

[project @ 2000-03-24 14:32:03 by sewardj]

Reimplement interrupt handling in a way compatible with the
revised module chaser, etc.
parent 300f02db
......@@ -11,8 +11,8 @@
* included in the distribution.
*
* $RCSfile: compiler.c,v $
* $Revision: 1.24 $
* $Date: 2000/03/23 14:54:20 $
* $Revision: 1.25 $
* $Date: 2000/03/24 14:32:03 $
* ------------------------------------------------------------------------*/
#include "hugsbasictypes.h"
......@@ -1462,15 +1462,6 @@ static List addGlobals( List binds )
return binds;
}
typedef void (*sighandler_t)(int);
void eval_ctrlbrk ( int dunnowhat )
{
interruptStgRts();
/* reinstall the signal handler so that further interrupts which
happen before the thread can return to the scheduler, lead back
here rather than invoking the previous break handler. */
signal(SIGINT, eval_ctrlbrk);
}
Void evalExp ( void ) { /* compile and run input expression */
/* ToDo: this name (and other names generated during pattern match?)
......@@ -1494,19 +1485,17 @@ Void evalExp ( void ) { /* compile and run input expression */
unless doRevertCAFs below is permanently TRUE.
*/
/* initScheduler(); */
#ifdef CRUDE_PROFILING
# ifdef CRUDE_PROFILING
cp_init();
#endif
# endif
{
HaskellObj result; /* ignored */
sighandler_t old_ctrlbrk;
SchedulerStatus status;
Bool doRevertCAFs = TRUE; /* do not change -- comment above */
old_ctrlbrk = signal(SIGINT, eval_ctrlbrk);
ASSERT(old_ctrlbrk != SIG_ERR);
HugsBreakAction brkOld = setBreakAction ( HugsRtsInterrupt );
status = rts_eval_(closureOfVar(v),10000,&result);
signal(SIGINT,old_ctrlbrk);
setBreakAction ( brkOld );
fflush (stderr);
fflush (stdout);
switch (status) {
......
......@@ -9,8 +9,8 @@
* included in the distribution.
*
* $RCSfile: connect.h,v $
* $Revision: 1.32 $
* $Date: 2000/03/22 18:14:22 $
* $Revision: 1.33 $
* $Date: 2000/03/24 14:32:03 $
* ------------------------------------------------------------------------*/
/* --------------------------------------------------------------------------
......@@ -312,7 +312,6 @@ extern Int whnfInt; /* integer value of term in whnf */
extern Float whnfFloat; /* float value of term in whnf */
extern Long numCells; /* number of cells allocated */
extern Int numGcs; /* number of garbage collections */
extern Bool broken; /* indicates interrupt received */
extern Bool preludeLoaded; /* TRUE => prelude has been loaded */
extern Bool flagAssert; /* TRUE => assert False <e> causes
an assertion failure */
......@@ -557,38 +556,31 @@ extern Bool stdcallAllowed ( void );
* Interrupting execution (signals, allowBreak):
*-------------------------------------------------------------------------*/
extern Bool breakOn ( Bool );
extern Bool broken; /* indicates interrupt received */
typedef
enum { HugsIgnoreBreak, HugsLongjmpOnBreak, HugsRtsInterrupt }
HugsBreakAction;
extern HugsBreakAction currentBreakAction;
extern HugsBreakAction setBreakAction ( HugsBreakAction );
#ifndef SIGBREAK /* Sigh, not defined in cygwin32 beta release 16 */
# define SIGBREAK 21
#endif
/* allowBreak: call to allow user to interrupt computation
* ctrlbrk: set control break handler
*/
#if HAVE_SIGPROCMASK
/* ctrlbrk: set the interrupt handler.
Hugs relies on being able to do sigprocmask, since some of
the signal handlers do longjmps, and this zaps the previous
signal mask. So setHandler needs to do sigprocmask in order
to get the signal mask to a sane state each time.
*/
#include <signal.h>
#define ctrlbrk(bh) { sigset_t mask; \
signal(SIGINT,bh); \
sigemptyset(&mask); \
sigaddset(&mask, SIGINT); \
sigprocmask(SIG_UNBLOCK, &mask, NULL); \
}
#else
# define ctrlbrk(bh) signal(SIGINT,bh)
#endif
#if SYMANTEC_C
extern int time_release;
extern int allow_break_count;
# define allowBreak() if (time_release !=0 && \
(++allow_break_count % time_release) == 0) \
ProcessEvent();
#else
# define allowBreak() if (broken) { broken=FALSE; sigRaise(breakHandler); }
#endif
#define setHandler(bh) { sigset_t mask; \
signal(SIGINT,bh); \
sigemptyset(&mask); \
sigaddset(&mask, SIGINT); \
sigprocmask(SIG_UNBLOCK, &mask, NULL); \
}
/*---------------------------------------------------------------------------
......
......@@ -9,8 +9,8 @@
* included in the distribution.
*
* $RCSfile: errors.h,v $
* $Revision: 1.8 $
* $Date: 2000/03/22 18:14:22 $
* $Revision: 1.9 $
* $Date: 2000/03/24 14:32:03 $
* ------------------------------------------------------------------------*/
extern Void internal ( String) HUGS_noreturn;
......@@ -39,10 +39,6 @@ extern Void errFail_no_longjmp ( Void );
extern Void errAbort ( Void );
extern Cell errAssert ( Int );
extern sigProto(breakHandler);
extern Bool breakOn ( Bool ); /* in machdep.c */
extern Void printExp ( FILE *,Cell ); /* in output.c */
extern Void printType ( FILE *,Cell );
extern Void printContext ( FILE *,List );
......
......@@ -9,8 +9,8 @@
* included in the distribution.
*
* $RCSfile: hugs.c,v $
* $Revision: 1.48 $
* $Date: 2000/03/24 12:36:43 $
* $Revision: 1.49 $
* $Date: 2000/03/24 14:32:03 $
* ------------------------------------------------------------------------*/
#include <setjmp.h>
......@@ -732,6 +732,50 @@ static Void local changeDir() { /* change directory */
}
/* --------------------------------------------------------------------------
* Interrupt handling
* ------------------------------------------------------------------------*/
static jmp_buf catch_error; /* jump buffer for error trapping */
HugsBreakAction currentBreakAction = HugsIgnoreBreak;
static void handler_IgnoreBreak ( int sig )
{
setHandler ( handler_IgnoreBreak );
}
static void handler_LongjmpOnBreak ( int sig )
{
setHandler ( handler_LongjmpOnBreak );
Printf("{Interrupted!}\n");
longjmp(catch_error,1);
}
static void handler_RtsInterrupt ( int sig )
{
setHandler ( handler_RtsInterrupt );
interruptStgRts();
}
HugsBreakAction setBreakAction ( HugsBreakAction newAction )
{
HugsBreakAction tmp = currentBreakAction;
currentBreakAction = newAction;
switch (newAction) {
case HugsIgnoreBreak:
setHandler ( handler_IgnoreBreak ); break;
case HugsLongjmpOnBreak:
setHandler ( handler_LongjmpOnBreak ); break;
case HugsRtsInterrupt:
setHandler ( handler_RtsInterrupt ); break;
default:
internal("setBreakAction");
}
return tmp;
}
/* --------------------------------------------------------------------------
* The new module chaser, loader, etc
* ------------------------------------------------------------------------*/
......@@ -739,7 +783,6 @@ static Void local changeDir() { /* change directory */
List moduleGraph = NIL;
List prelModules = NIL;
List targetModules = NIL;
static jmp_buf catch_error; /* jump buffer for error trapping */
static void setCurrentFile ( Module mod )
{
......@@ -1204,6 +1247,8 @@ static void achieveTargetModules ( void )
volatile Cell grp;
volatile List badMods;
setBreakAction ( HugsIgnoreBreak );
/* First, examine timestamps to find out which modules are
out of date with respect to the source/interface/object files.
*/
......@@ -1338,6 +1383,7 @@ static void achieveTargetModules ( void )
if (!varIsMember(textOf(mc),modgList)
&& !varIsMember(textOf(mc),parsedButNotLoaded)) {
setBreakAction ( HugsLongjmpOnBreak );
if (setjmp(catch_error)==0) {
/* try this; it may throw an exception */
mod = parseModuleOrInterface (
......@@ -1345,6 +1391,7 @@ static void achieveTargetModules ( void )
} else {
/* here's the exception handler, if parsing fails */
/* A parse error (or similar). Clean up and abort. */
setBreakAction ( HugsIgnoreBreak );
mod = findModule(textOf(mc));
if (nonNull(mod)) nukeModule(mod);
for (t = parsedButNotLoaded; nonNull(t); t=tl(t)) {
......@@ -1355,6 +1402,7 @@ static void achieveTargetModules ( void )
return;
/* end of the exception handler */
}
setBreakAction ( HugsIgnoreBreak );
parsedButNotLoaded = cons(mc, parsedButNotLoaded);
toChase = dupOnto(module(mod).uses,toChase);
......@@ -1417,6 +1465,7 @@ static void achieveTargetModules ( void )
if (!varIsMember(textOf(selectArbitrarilyFromGroup(grp)),
parsedButNotLoaded)) continue;
setBreakAction ( HugsLongjmpOnBreak );
if (setjmp(catch_error)==0) {
/* try this; it may throw an exception */
tryLoadGroup(grp);
......@@ -1424,6 +1473,7 @@ static void achieveTargetModules ( void )
/* here's the exception handler, if static/typecheck etc fails */
/* nuke the entire rest (ie, the unloaded part)
of the module graph */
setBreakAction ( HugsIgnoreBreak );
badMods = listFromSpecifiedMG ( mg );
for (t = badMods; nonNull(t); t=tl(t)) {
mod = findModule(textOf(hd(t)));
......@@ -1442,12 +1492,13 @@ static void achieveTargetModules ( void )
return;
/* end of the exception handler */
}
setBreakAction ( HugsIgnoreBreak );
}
/* Err .. I think that's it. If we get here, we've successfully
achieved the target set. Phew!
*/
setBreakAction ( HugsIgnoreBreak );
}
......@@ -1643,6 +1694,7 @@ static Void local evaluator() { /* evaluate expr and print value */
defaultDefns = combined ? stdDefaults : evalDefaults;
setBreakAction ( HugsLongjmpOnBreak );
if (setjmp(catch_error)==0) {
/* try this */
parseExp();
......@@ -1650,9 +1702,11 @@ static Void local evaluator() { /* evaluate expr and print value */
type = typeCheckExp(TRUE);
} else {
/* if an exception happens, we arrive here */
setBreakAction ( HugsIgnoreBreak );
goto cleanup_and_return;
}
setBreakAction ( HugsIgnoreBreak );
if (isPolyType(type)) {
ks = polySigOf(type);
bd = monotypeOf(type);
......@@ -1707,6 +1761,7 @@ static Void local evaluator() { /* evaluate expr and print value */
#endif
cleanup_and_return:
setBreakAction ( HugsIgnoreBreak );
nukeModule(evalMod);
setCurrModule(currMod);
setCurrentFile(currMod);
......@@ -2258,8 +2313,9 @@ String argv[]; {
Bool prelOK;
String s;
breakOn(TRUE); /* enable break trapping */
setBreakAction ( HugsIgnoreBreak );
modConIds = initialize(argc,argv); /* the initial modules to load */
setBreakAction ( HugsIgnoreBreak );
prelOK = loadThePrelude();
if (combined) everybody(POSTPREL);
......@@ -2285,7 +2341,7 @@ String argv[]; {
modConIds = NIL;
/* initialize calls startupHaskell, which trashes our signal handlers */
breakOn(TRUE);
setBreakAction ( HugsIgnoreBreak );
forHelp();
for (;;) {
......@@ -2364,7 +2420,6 @@ String argv[]; {
if (autoMain) break;
}
breakOn(FALSE);
}
/* --------------------------------------------------------------------------
......@@ -2537,20 +2592,6 @@ String msg; {
exit(1);
}
sigHandler(breakHandler) { /* respond to break interrupt */
Hilite();
Printf("{Interrupted!}\n");
Lolite();
breakOn(TRUE); /* reinstall signal handler - redundant on BSD systems */
/* but essential on POSIX (and other?) systems */
everybody(BREAK);
failed();
stopAnyPrinting();
FlushStdout();
clearerr(stdin);
longjmp(catch_error,1);
sigResume;/*NOTREACHED*/
}
/* --------------------------------------------------------------------------
* Read value from environment variable or registry:
......
......@@ -10,8 +10,8 @@
* included in the distribution.
*
* $RCSfile: hugsbasictypes.h,v $
* $Revision: 1.1 $
* $Date: 2000/03/23 14:54:21 $
* $Revision: 1.2 $
* $Date: 2000/03/24 14:32:03 $
* ------------------------------------------------------------------------*/
#define NON_POSIX_SOURCE
......@@ -164,22 +164,6 @@ extern int stricmp Args((const char *, const char*));
#endif
#endif
/*---------------------------------------------------------------------------
* Interrupting execution (signals, allowBreak):
*-------------------------------------------------------------------------*/
#if !DOS && VOID_INT_SIGNALS
# define sigProto(nm) void nm ( int )
# define sigRaise(nm) nm(1)
# define sigHandler(nm) void nm ( sig_arg ) int sig_arg;
# define sigResume return
#else
# define sigProto(nm) int nm ( Void )
# define sigRaise(nm) nm()
# define sigHandler(nm) int nm ( Void )
# define sigResume return 1
#endif
/*---------------------------------------------------------------------------
* Assertions
*-------------------------------------------------------------------------*/
......
......@@ -9,8 +9,8 @@
* included in the distribution.
*
* $RCSfile: input.c,v $
* $Revision: 1.23 $
* $Date: 2000/03/23 14:54:21 $
* $Revision: 1.24 $
* $Date: 2000/03/24 14:32:03 $
* ------------------------------------------------------------------------*/
#include "hugsbasictypes.h"
......@@ -562,7 +562,7 @@ static Void local skip() { /* move forward one char in input */
closeAnyInput();
}
else if (reading==KEYBOARD) {
allowBreak();
/* allowBreak(); */
if (c0=='\n')
c1 = EOF;
else {
......@@ -574,7 +574,7 @@ static Void local skip() { /* move forward one char in input */
* fail - returning "-1" to indicate an error.
* This is one of the rare cases where "-1" does not mean EOF.
*/
if (EOF == c1 && (!feof(stdin) || broken==TRUE)) {
if (EOF == c1 && (!feof(stdin) /* || broken==TRUE */)) {
c1 = ' ';
}
}
......
......@@ -13,8 +13,8 @@
* included in the distribution.
*
* $RCSfile: machdep.c,v $
* $Revision: 1.22 $
* $Date: 2000/03/22 18:14:22 $
* $Revision: 1.23 $
* $Date: 2000/03/24 14:32:03 $
* ------------------------------------------------------------------------*/
#ifdef HAVE_SIGNAL_H
......@@ -1166,63 +1166,7 @@ Int readTerminalChar() { /* read character from terminal */
* Interrupt handling:
* ------------------------------------------------------------------------*/
Bool broken = FALSE;
static Bool breakReqd = FALSE;
static sigProto(ignoreBreak);
static Void local installHandlers ( Void );
Bool breakOn(reqd) /* set break trapping on if reqd, */
Bool reqd; { /* or off otherwise, returning old */
Bool old = breakReqd;
breakReqd = reqd;
if (reqd) {
if (broken) { /* repond to break signal received */
broken = FALSE; /* whilst break trap disabled */
sigRaise(breakHandler);
/* not reached */
}
#if HANDLERS_CANT_LONGJMP
ctrlbrk(ignoreBreak);
#else
ctrlbrk(breakHandler);
#endif
} else {
ctrlbrk(ignoreBreak);
}
return old;
}
static sigHandler(ignoreBreak) { /* record but don't respond to break*/
ctrlbrk(ignoreBreak); /* reinstall signal handler */
/* redundant on BSD systems but essential */
/* on POSIX and other systems */
broken = TRUE;
interruptStgRts();
sigResume;
}
#if !DONT_PANIC
static sigProto(panic);
static sigHandler(panic) { /* exit in a panic, on receipt of */
everybody(EXIT); /* an unexpected signal */
fprintf(stderr,"\nUnexpected signal\n");
exit(1);
sigResume;/*NOTREACHED*/
}
#endif /* !DONT_PANIC */
#if IS_WIN32
BOOL WINAPI consoleHandler(DWORD dwCtrlType) {
switch (dwCtrlType) { /* Allows Hugs to be terminated */
case CTRL_CLOSE_EVENT : /* from the window's close menu. */
ExitProcess(0);
}
return FALSE;
}
#endif
static Void local installHandlers() { /* Install handlers for all fatal */
static Void installHandlers ( void ) { /* Install handlers for all fatal */
/* signals except SIGINT and SIGBREAK*/
#if IS_WIN32
SetConsoleCtrlHandler(consoleHandler,TRUE);
......
......@@ -9,8 +9,8 @@
* included in the distribution.
*
* $RCSfile: storage.c,v $
* $Revision: 1.54 $
* $Date: 2000/03/24 12:36:43 $
* $Revision: 1.55 $
* $Date: 2000/03/24 14:32:03 $
* ------------------------------------------------------------------------*/
#include "hugsbasictypes.h"
......@@ -1993,12 +1993,14 @@ Cell n; { /* it was a cell ref, but don't */
}
Void garbageCollect() { /* Run garbage collector ... */
Bool breakStat = breakOn(FALSE); /* disable break checking */
/* disable break checking */
Int i,j;
register Int mask;
register Int place;
Int recovered;
jmp_buf regs; /* save registers on stack */
HugsBreakAction oldBrk
= setBreakAction ( HugsIgnoreBreak );
fprintf ( stderr, "wa-hey! garbage collection! too difficult! bye!\n" );
exit(0);
setjmp(regs);
......@@ -2032,7 +2034,7 @@ exit(0);
}
gcRecovered(recovered);
breakOn(breakStat); /* restore break trapping if nec. */
setBreakAction ( oldBrk );
everybody(GCDONE);
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment