* 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"
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?)
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) {
* 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 $
* ------------------------------------------------------------------------*/
/* --------------------------------------------------------------------------
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 */
* 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); \
+ }
/*---------------------------------------------------------------------------
* 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;
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 );
* 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>
/* --------------------------------------------------------------------------
+ * 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
* ------------------------------------------------------------------------*/
List moduleGraph = NIL;
List prelModules = NIL;
List targetModules = NIL;
-static jmp_buf catch_error; /* jump buffer for error trapping */
static void setCurrentFile ( Module mod )
{
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.
*/
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 (
} 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)) {
return;
/* end of the exception handler */
}
+ setBreakAction ( HugsIgnoreBreak );
parsedButNotLoaded = cons(mc, parsedButNotLoaded);
toChase = dupOnto(module(mod).uses,toChase);
if (!varIsMember(textOf(selectArbitrarilyFromGroup(grp)),
parsedButNotLoaded)) continue;
+ setBreakAction ( HugsLongjmpOnBreak );
if (setjmp(catch_error)==0) {
/* try this; it may throw an exception */
tryLoadGroup(grp);
/* 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)));
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 );
}
defaultDefns = combined ? stdDefaults : evalDefaults;
+ setBreakAction ( HugsLongjmpOnBreak );
if (setjmp(catch_error)==0) {
/* try this */
parseExp();
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);
#endif
cleanup_and_return:
+ setBreakAction ( HugsIgnoreBreak );
nukeModule(evalMod);
setCurrModule(currMod);
setCurrentFile(currMod);
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);
modConIds = NIL;
/* initialize calls startupHaskell, which trashes our signal handlers */
- breakOn(TRUE);
+ setBreakAction ( HugsIgnoreBreak );
forHelp();
for (;;) {
if (autoMain) break;
}
- breakOn(FALSE);
}
/* --------------------------------------------------------------------------
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:
* 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
#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
*-------------------------------------------------------------------------*/
* 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"
closeAnyInput();
}
else if (reading==KEYBOARD) {
- allowBreak();
+ /* allowBreak(); */
if (c0=='\n')
c1 = EOF;
else {
* 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 = ' ';
}
}
* 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
* 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);
* 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"
}
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);
}
gcRecovered(recovered);
- breakOn(breakStat); /* restore break trapping if nec. */
+ setBreakAction ( oldBrk );
everybody(GCDONE);
projects / ghc-hetmet.git / commitdiff