/* -----------------------------------------------------------------------------
- * $Id: PrimOps.h,v 1.36 1999/08/25 10:23:51 simonmar Exp $
+ * $Id: PrimOps.h,v 1.37 1999/08/25 16:11:43 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
Delay/Wait PrimOps
-------------------------------------------------------------------------- */
-/* Hmm, I'll think about these later. */
+EF_(waitReadzh_fast);
+EF_(waitWritezh_fast);
+EF_(delayzh_fast);
/* -----------------------------------------------------------------------------
Primitive I/O, error-handling PrimOps
/* -----------------------------------------------------------------------------
- * $Id: Rts.h,v 1.6 1999/02/05 16:02:27 simonm Exp $
+ * $Id: Rts.h,v 1.7 1999/08/25 16:11:44 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
#define stg_min(a,b) ({typeof(a) _a = (a), _b = (b); _a <= _b ? _a : _b; })
#define stg_max(a,b) ({typeof(a) _a = (a), _b = (b); _a <= _b ? _b : _a; })
-#define UNUSED __attribute__((unused))
-
#endif RTS_H
/* -----------------------------------------------------------------------------
- * $Id: TSO.h,v 1.7 1999/05/11 16:47:42 keithw Exp $
+ * $Id: TSO.h,v 1.8 1999/08/25 16:11:44 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
ThreadFinished
} StgThreadReturnCode;
+/*
+ * Threads may be blocked for several reasons. A blocked thread will
+ * have the reason in the why_blocked field of the TSO, and some
+ * further info (such as the closure the thread is blocked on, or the
+ * file descriptor if the thread is waiting on I/O) in the block_info
+ * field.
+ */
+
+typedef enum {
+ NotBlocked,
+ BlockedOnMVar,
+ BlockedOnBlackHole,
+ BlockedOnRead,
+ BlockedOnWrite,
+ BlockedOnDelay
+} StgTSOBlockReason;
+
+typedef union {
+ StgClosure *closure;
+ int fd;
+ unsigned int delay;
+} StgTSOBlockInfo;
+
/*
* TSOs live on the heap, and therefore look just like heap objects.
* Large TSOs will live in their own "block group" allocated by the
struct StgTSO_* link;
StgMutClosure * mut_link; /* TSO's are mutable of course! */
StgTSOWhatNext whatNext;
- StgClosure * blocked_on;
+ StgTSOBlockReason why_blocked;
+ StgTSOBlockInfo block_info;
StgThreadID id;
StgTSOTickyInfo ticky;
StgTSOProfInfo prof;
/* -----------------------------------------------------------------------------
- * $Id: Updates.h,v 1.11 1999/05/13 17:31:08 simonm Exp $
+ * $Id: Updates.h,v 1.12 1999/08/25 16:11:44 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
Awaken any threads waiting on this computation
-------------------------------------------------------------------------- */
-extern void awaken_blocked_queue(StgTSO *q);
+extern void awakenBlockedQueue(StgTSO *q);
#define AWAKEN_BQ(closure) \
if (closure->header.info == &BLACKHOLE_BQ_info) { \
StgTSO *bq = ((StgBlockingQueue *)closure)->blocking_queue;\
if (bq != (StgTSO *)&END_TSO_QUEUE_closure) { \
- STGCALL1(awaken_blocked_queue, bq); \
+ STGCALL1(awakenBlockedQueue, bq); \
} \
}
, fork -- :: a -> b -> b
, yield -- :: IO ()
- {-threadDelay, threadWaitRead, threadWaitWrite,-}
+ , threadDelay -- :: Int -> IO ()
+ , threadWaitRead -- :: Int -> IO ()
+ , threadWaitWrite -- :: Int -> IO ()
-- MVars
, MVar -- abstract
import Semaphore
import SampleVar
import PrelConc
-import PrelHandle ( topHandler )
+import PrelHandle ( topHandler, threadDelay,
+ threadWaitRead, threadWaitWrite )
import PrelException
import PrelIOBase ( IO(..) )
import IO
/* -----------------------------------------------------------------------------
- * $Id: GC.c,v 1.60 1999/06/29 13:04:38 panne Exp $
+ * $Id: GC.c,v 1.61 1999/08/25 16:11:46 simonmar Exp $
*
* (c) The GHC Team 1998-1999
*
evac_gen = 0;
/* chase the link field for any TSOs on the same queue */
(StgClosure *)tso->link = evacuate((StgClosure *)tso->link);
- if (tso->blocked_on) {
- tso->blocked_on = evacuate(tso->blocked_on);
+ if ( tso->why_blocked == BlockedOnMVar
+ || tso->why_blocked == BlockedOnBlackHole) {
+ tso->block_info.closure = evacuate(tso->block_info.closure);
}
/* scavenge this thread's stack */
scavenge_stack(tso->sp, &(tso->stack[tso->stack_size]));
StgTSO *tso = (StgTSO *)p;
(StgClosure *)tso->link = evacuate((StgClosure *)tso->link);
- if (tso->blocked_on) {
- tso->blocked_on = evacuate(tso->blocked_on);
+ if ( tso->why_blocked == BlockedOnMVar
+ || tso->why_blocked == BlockedOnBlackHole) {
+ tso->block_info.closure = evacuate(tso->block_info.closure);
}
scavenge_stack(tso->sp, &(tso->stack[tso->stack_size]));
tso = (StgTSO *)p;
/* chase the link field for any TSOs on the same queue */
(StgClosure *)tso->link = evacuate((StgClosure *)tso->link);
- if (tso->blocked_on) {
- tso->blocked_on = evacuate(tso->blocked_on);
+ if ( tso->why_blocked == BlockedOnMVar
+ || tso->why_blocked == BlockedOnBlackHole) {
+ tso->block_info.closure = evacuate(tso->block_info.closure);
}
/* scavenge this thread's stack */
scavenge_stack(tso->sp, &(tso->stack[tso->stack_size]));
+/* -----------------------------------------------------------------------------
+ * $Id: HeapStackCheck.h,v 1.4 1999/08/25 16:11:48 simonmar Exp $
+ *
+ * (c) The GHC Team, 1998-1999
+ *
+ * Prototypes for functions in HeapStackCheck.hc
+ *
+ * ---------------------------------------------------------------------------*/
+
EXTFUN(stg_gc_entertop);
EXTFUN(stg_gc_enter_1);
EXTFUN(stg_gc_enter_2);
EXTFUN(stg_yield_noregs);
EXTFUN(stg_yield_to_Hugs);
EXTFUN(stg_gen_block);
+EXTFUN(stg_block_noregs);
EXTFUN(stg_block_1);
/* -----------------------------------------------------------------------------
- * $Id: HeapStackCheck.hc,v 1.8 1999/05/24 10:58:09 simonmar Exp $
+ * $Id: HeapStackCheck.hc,v 1.9 1999/08/25 16:11:48 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
/*-- No regsiters live (probably a void return) ----------------------------- */
+/* If we change the policy for thread startup to *not* remove the
+ * return address from the stack, we can get rid of this little
+ * function/info table...
+ */
INFO_TABLE_SRT_BITMAP(stg_gc_noregs_ret_info, stg_gc_noregs_ret, 0/*BITMAP*/,
0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_LEN*/,
RET_SMALL,, EF_, 0, 0);
FE_
}
-INFO_TABLE_SRT_BITMAP(stg_yield_noregs_info, stg_yield_noregs_ret, 0/*BITMAP*/,
- 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_LEN*/,
- RET_SMALL,, EF_, 0, 0);
-
-FN_(stg_yield_noregs_ret)
-{
- FB_
- JMP_(ENTRY_CODE(Sp[0]));
- FE_
-}
-
FN_(stg_yield_noregs)
{
FB_
Sp--;
- Sp[0] = (W_)&stg_yield_noregs_info;
+ Sp[0] = (W_)&stg_gc_noregs_ret_info;
YIELD_GENERIC;
FE_
}
FE_
}
+FN_(stg_block_noregs)
+{
+ FB_
+ Sp--;
+ Sp[0] = (W_)&stg_gc_noregs_ret_info;
+ BLOCK_GENERIC;
+ FE_
+}
+
FN_(stg_block_1)
{
FB_
/* -----------------------------------------------------------------------------
- * $Id: Itimer.c,v 1.4 1999/03/03 19:00:07 sof Exp $
+ * $Id: Itimer.c,v 1.5 1999/08/25 16:11:48 simonmar Exp $
*
* (c) The GHC Team, 1995-1999
*
#include "Rts.h"
#include "Itimer.h"
+#include "Schedule.h"
/* As recommended in the autoconf manual */
# ifdef TIME_WITH_SYS_TIME
# include <windows.h>
#endif
+lnat total_ticks = 0;
+rtsBool do_prof_ticks = rtsFalse;
+
+static void handle_tick(int unused STG_UNUSED);
+
+/* -----------------------------------------------------------------------------
+ Tick handler
+
+ We use the ticker for two things: supporting threadDelay, and time
+ profiling.
+ -------------------------------------------------------------------------- */
+
+static void
+handle_tick(int unused STG_UNUSED)
+{
+ total_ticks++;
+
+#ifdef PROFILING
+ if (do_prof_ticks = rtsTrue) {
+ CCS_TICK(CCCS);
+ }
+#endif
+
+ /* For threadDelay etc., see Select.c */
+ ticks_since_select++;
+}
+
+
/*
* Handling timer events under cygwin32 is not done with signal/setitimer.
* Instead of the two steps of first registering a signal handler to handle
#if defined(mingw32_TARGET_OS) || (defined(cygwin32_TARGET_OS) && !defined(HAVE_SETITIMER))
int
-install_vtalrm_handler(void (*handler)(int))
+install_vtalrm_handler(void)
{
- vtalrm_cback = handler;
+ vtalrm_cback = handle_tick;
return 0;
}
#else
int
-install_vtalrm_handler(void (*handler)(int))
+install_vtalrm_handler(void)
{
struct sigaction action;
- action.sa_handler = handler;
+ action.sa_handler = handle_tick;
sigemptyset(&action.sa_mask);
action.sa_flags = 0;
/* -----------------------------------------------------------------------------
- * $Id: Itimer.h,v 1.3 1999/02/05 16:02:44 simonm Exp $
+ * $Id: Itimer.h,v 1.4 1999/08/25 16:11:48 simonmar Exp $
*
* (c) The GHC Team 1998-1999
*
*
* ---------------------------------------------------------------------------*/
+# define TICK_FREQUENCY 50 /* ticks per second */
+# define TICK_MILLISECS (1000/TICK_FREQUENCY) /* ms per tick */
+
+extern rtsBool do_prof_ticks; /* profiling ticks on/off */
+
nat initialize_virtual_timer ( nat ms );
-int install_vtalrm_handler ( void (*handler)(int) );
+int install_vtalrm_handler ( void );
void block_vtalrm_signal ( void );
void unblock_vtalrm_signal ( void );
-
-
/* -----------------------------------------------------------------------------
- * $Id: PrimOps.hc,v 1.28 1999/07/14 13:42:28 simonmar Exp $
+ * $Id: PrimOps.hc,v 1.29 1999/08/25 16:11:48 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
mvar->tail->link = CurrentTSO;
}
CurrentTSO->link = (StgTSO *)&END_TSO_QUEUE_closure;
- CurrentTSO->blocked_on = (StgClosure *)mvar;
+ CurrentTSO->why_blocked = BlockedOnMVar;
+ CurrentTSO->block_info.closure = (StgClosure *)mvar;
mvar->tail = CurrentTSO;
BLOCK(R1_PTR, takeMVarzh_fast);
FN_(putMVarzh_fast)
{
StgMVar *mvar;
- StgTSO *tso;
FB_
/* args: R1 = MVar, R2 = value */
SET_INFO(mvar,&FULL_MVAR_info);
mvar->value = R2.cl;
- /* wake up the first thread on the queue,
- * it will continue with the takeMVar operation and mark the MVar
- * empty again.
+ /* wake up the first thread on the queue, it will continue with the
+ * takeMVar operation and mark the MVar empty again.
*/
- tso = mvar->head;
- if (tso != (StgTSO *)&END_TSO_QUEUE_closure) {
- PUSH_ON_RUN_QUEUE(tso);
- mvar->head = tso->link;
- tso->link = (StgTSO *)&END_TSO_QUEUE_closure;
+ if (mvar->head != (StgTSO *)&END_TSO_QUEUE_closure) {
+ ASSERT(mvar->head->why_blocked == BlockedOnMVar);
+ mvar->head = RET_STGCALL1(StgTSO *,unblockOne,mvar->head);
if (mvar->head == (StgTSO *)&END_TSO_QUEUE_closure) {
mvar->tail = (StgTSO *)&END_TSO_QUEUE_closure;
}
RET_P(sn_obj);
}
+/* -----------------------------------------------------------------------------
+ Thread I/O blocking primitives
+ -------------------------------------------------------------------------- */
+
+FN_(waitReadzh_fast)
+{
+ FB_
+ /* args: R1.i */
+ ASSERT(CurrentTSO->why_blocked == NotBlocked);
+ CurrentTSO->why_blocked = BlockedOnRead;
+ CurrentTSO->block_info.fd = R1.i;
+ PUSH_ON_BLOCKED_QUEUE(CurrentTSO);
+ JMP_(stg_block_noregs);
+ FE_
+}
+
+FN_(waitWritezh_fast)
+{
+ FB_
+ /* args: R1.i */
+ ASSERT(CurrentTSO->why_blocked == NotBlocked);
+ CurrentTSO->why_blocked = BlockedOnWrite;
+ CurrentTSO->block_info.fd = R1.i;
+ PUSH_ON_BLOCKED_QUEUE(CurrentTSO);
+ JMP_(stg_block_noregs);
+ FE_
+}
+
+FN_(delayzh_fast)
+{
+ FB_
+ /* args: R1.i */
+ ASSERT(CurrentTSO->why_blocked == NotBlocked);
+ CurrentTSO->why_blocked = BlockedOnDelay;
+
+ /* Add on ticks_since_select, since these will be subtracted at
+ * the next awaitEvent call.
+ */
+ CurrentTSO->block_info.delay = R1.i + ticks_since_select;
+
+ PUSH_ON_BLOCKED_QUEUE(CurrentTSO);
+ JMP_(stg_block_noregs);
+ FE_
+}
+
#endif /* COMPILER */
/* -----------------------------------------------------------------------------
- * $Id: ProfRts.h,v 1.3 1999/02/05 16:02:47 simonm Exp $
+ * $Id: ProfRts.h,v 1.4 1999/08/25 16:11:49 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
void report_ccs_profiling( void );
-# define TICK_FREQUENCY 50 /* ticks per second */
-# define TICK_MILLISECS (1000/TICK_FREQUENCY) /* ms per tick */
-
# define DEFAULT_INTERVAL TICK_FREQUENCY
extern rtsBool time_profiling;
/* -----------------------------------------------------------------------------
- * $Id: Profiling.c,v 1.7 1999/06/29 13:04:40 panne Exp $
+ * $Id: Profiling.c,v 1.8 1999/08/25 16:11:49 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
/* figures for the profiling report.
*/
-static lnat total_alloc, total_ticks;
+static lnat total_alloc, total_prof_ticks;
/* Globals for opening the profiling log file
*/
ccs = next;
}
- /* profiling is the only client of the VTALRM system at the moment,
- * so just install the profiling tick handler. */
- install_vtalrm_handler(handleProfTick);
+ /* Start ticking */
startProfTimer();
};
}
void
-heapCensus ( bdescr *bd UNUSED )
+heapCensus ( bdescr *bd STG_UNUSED )
{
/* nothing yet */
}
stopProfTimer();
- total_ticks = 0;
+ total_prof_ticks = 0;
total_alloc = 0;
count_ticks(CCS_MAIN);
fprintf(prof_file, "\n\n");
fprintf(prof_file, "\ttotal time = %11.2f secs (%lu ticks @ %d ms)\n",
- total_ticks / (StgFloat) TICK_FREQUENCY,
- total_ticks, TICK_MILLISECS);
+ total_prof_ticks / (StgFloat) TICK_FREQUENCY,
+ total_prof_ticks, TICK_MILLISECS);
fprintf(prof_file, "\ttotal alloc = %11s bytes",
ullong_format_string((ullong) total_alloc * sizeof(W_),
fprintf(prof_file, "%8ld %4.1f %4.1f %8ld %5ld",
ccs->scc_count,
- total_ticks == 0 ? 0.0 : (ccs->time_ticks / (StgFloat) total_ticks * 100),
+ total_prof_ticks == 0 ? 0.0 : (ccs->time_ticks / (StgFloat) total_prof_ticks * 100),
total_alloc == 0 ? 0.0 : (ccs->mem_alloc / (StgFloat) total_alloc * 100),
ccs->sub_scc_count, ccs->sub_cafcc_count);
if (!ccs_to_ignore(ccs)) {
total_alloc += ccs->mem_alloc;
- total_ticks += ccs->time_ticks;
+ total_prof_ticks += ccs->time_ticks;
}
for (i = ccs->indexTable; i != NULL; i = i->next)
count_ticks(i->ccs);
/* -----------------------------------------------------------------------------
- * $Id: Proftimer.c,v 1.4 1999/08/04 17:03:41 panne Exp $
+ * $Id: Proftimer.c,v 1.5 1999/08/25 16:11:49 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
#include "Itimer.h"
#include "Proftimer.h"
-lnat total_ticks = 0;
-
nat current_interval = 1; /* Current interval number --
stored in AGE */
nat current_ticks = 0; /* ticks in current interval */
void
-initProfTimer(nat ms)
-{
- if (initialize_virtual_timer(ms)) {
- fflush(stdout);
- fprintf(stderr, "Can't initialize virtual timer.\n");
- stg_exit(EXIT_FAILURE);
- }
-};
-
-void
stopProfTimer(void)
{ /* Stops time profile */
if (time_profiling) {
- initProfTimer(0);
+ do_prof_ticks = rtsFalse;
}
};
startProfTimer(void)
{ /* Starts time profile */
if (time_profiling) {
- initProfTimer(TICK_MILLISECS);
+ do_prof_ticks = rtsTrue;
}
};
-/* For a small collection of signal handler prototypes, see
- http://web2.airmail.net/sjbaker1/software/signal_collection.html */
-
-void
-handleProfTick(int unused)
-{
- (void)unused; /* no warnings, please */
- CCS_TICK(CCCS);
- total_ticks++;
-};
-
#endif /* PROFILING */
/* -----------------------------------------------------------------------------
- * $Id: Proftimer.h,v 1.3 1999/08/04 17:03:41 panne Exp $
+ * $Id: Proftimer.h,v 1.4 1999/08/25 16:11:50 simonmar Exp $
*
* (c) The GHC Team, 1998
*
*
* ---------------------------------------------------------------------------*/
+extern lnat total_prof_ticks;
+
extern void initProfTimer(nat ms);
extern void stopProfTimer(void);
extern void startProfTimer(void);
/* -----------------------------------------------------------------------------
- * $Id: RtsFlags.c,v 1.14 1999/05/20 10:23:42 simonmar Exp $
+ * $Id: RtsFlags.c,v 1.15 1999/08/25 16:11:50 simonmar Exp $
*
* (c) The AQUA Project, Glasgow University, 1994-1997
* (c) The GHC Team, 1998-1999
RtsFlags.ProfFlags.doHeapProfile = rtsFalse;
#endif
-/* there really shouldn't be a threads limit for concurrent mandatory threads.
- For now, unlimitied means less than 64k (there's a storage overhead) -- SOF
-*/
-#if defined(CONCURRENT) && !defined(GRAN)
RtsFlags.ConcFlags.ctxtSwitchTime = CS_MIN_MILLISECS; /* In milliseconds */
- RtsFlags.ConcFlags.maxThreads = 65536;
- RtsFlags.ConcFlags.stkChunkSize = 1024;
- RtsFlags.ConcFlags.maxLocalSparks = 65536;
-#endif /* CONCURRENT only */
-
-#if GRAN
- RtsFlags.ConcFlags.ctxtSwitchTime = CS_MIN_MILLISECS; /* In milliseconds */
- RtsFlags.ConcFlags.maxThreads = 32;
- RtsFlags.ConcFlags.stkChunkSize = 1024;
- RtsFlags.ConcFlags.maxLocalSparks = 500;
-#endif /* GRAN */
-
#ifdef PAR
RtsFlags.ParFlags.parallelStats = rtsFalse;
RtsFlags.ParFlags.granSimStats = rtsFalse;
" -C<secs> Context-switch interval in seconds",
" (0 or no argument means switch as often as possible)",
" the default is .01 sec; resolution is .01 sec",
-" -e<size> Size of spark pools (default 100)",
# ifdef PAR
" -q Enable activity profile (output files in ~/<program>*.gr)",
" -qb Enable binary activity profile (output file /tmp/<program>.gb)",
" -Q<size> Set pack-buffer size (default: 1024)",
-# else
-" -q[v] Enable quasi-parallel profile (output file <program>.qp)",
# endif
-" -t<num> Set maximum number of advisory threads per PE (default 32)",
-" -o<num> Set stack chunk size (default 1024)",
# ifdef PAR
" -d Turn on PVM-ish debugging",
" -O Disable output for performance measurement",
}
break;
- case 't':
- if (rts_argv[arg][2] != '\0') {
- RtsFlags.ConcFlags.maxThreads
- = strtol(rts_argv[arg]+2, (char **) NULL, 10);
- } else {
- fprintf(stderr, "setupRtsFlags: missing size for -t\n");
- error = rtsTrue;
- }
- break;
-
/* =========== PARALLEL =========================== */
case 'e':
PAR_BUILD_ONLY(
/* -----------------------------------------------------------------------------
- * $Id: RtsFlags.h,v 1.14 1999/06/25 09:18:49 simonmar Exp $
+ * $Id: RtsFlags.h,v 1.15 1999/08/25 16:11:50 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
#ifdef PROFILING
struct PROFILING_FLAGS {
unsigned int doHeapProfile;
+
# define NO_HEAP_PROFILING 0 /* N.B. Used as indexes into arrays */
# define HEAP_BY_CC 1
# define HEAP_BY_MOD 2
struct CONCURRENT_FLAGS {
int ctxtSwitchTime; /* in milliseconds */
- int maxThreads;
};
#ifdef PAR
/* -----------------------------------------------------------------------------
- * $Id: RtsStartup.c,v 1.17 1999/07/06 15:33:23 simonmar Exp $
+ * $Id: RtsStartup.c,v 1.18 1999/08/25 16:11:50 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
#include "StablePriv.h" /* initStablePtrTable */
#include "Schedule.h" /* initScheduler */
#include "Stats.h" /* initStats */
+#include "Signals.h"
+#include "Itimer.h"
#include "Weak.h"
#include "Ticky.h"
initProfiling();
#endif
+ /* start the ticker */
+ install_vtalrm_handler();
+ initialize_virtual_timer(TICK_MILLISECS);
+
/* Initialise the scheduler */
initScheduler();
/* Initialise the stats department */
initStats();
-#if 0
+ /* Initialise the user signal handler set */
initUserSignals();
-#endif
/* When the RTS and Prelude live in separate DLLs,
we need to patch up the char- and int-like tables
/* clean up things from the storage manager's point of view */
exitStorage();
+ /* stop the ticker */
+ initialize_virtual_timer(0);
+
#if defined(PROFILING) || defined(DEBUG)
endProfiling();
#endif
/* -----------------------------------------------------------------------------
- * $Id: RtsUtils.c,v 1.8 1999/03/17 13:19:23 simonm Exp $
+ * $Id: RtsUtils.c,v 1.9 1999/08/25 16:11:51 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
{
va_list ap;
va_start(ap,s);
- fflush(stdout);
+ /* don't fflush(stdout); WORKAROUND bug in Linux glibc */
if (prog_argv != NULL && prog_argv[0] != NULL) {
fprintf(stderr, "%s: fatal error: ", prog_argv[0]);
} else {
{
va_list ap;
va_start(ap,s);
- fflush(stdout);
+ /* don't fflush(stdout); WORKAROUND bug in Linux glibc */
vfprintf(stderr, s, ap);
fprintf(stderr, "\n");
}
char *space;
if ((space = (char *) malloc((size_t) n)) == NULL) {
- fflush(stdout);
+ /* don't fflush(stdout); WORKAROUND bug in Linux glibc */
MallocFailHook((W_) n, msg); /*msg*/
stg_exit(EXIT_FAILURE);
}
char *space;
if ((space = (char *) realloc(p, (size_t) n)) == NULL) {
- fflush(stdout);
+ /* don't fflush(stdout); WORKAROUND bug in Linux glibc */
MallocFailHook((W_) n, msg); /*msg*/
exit(EXIT_FAILURE);
}
void
_stgAssert (char *filename, nat linenum)
{
- fflush(stdout);
+ /* don't fflush(stdout); WORKAROUND bug in Linux glibc */
fprintf(stderr, "ASSERTION FAILED: file %s, line %u\n", filename, linenum);
abort();
}
-StgStablePtr errorHandler = -1; /* -1 indicates no handler installed */
-
-void
-raiseError( StgStablePtr handler STG_UNUSED )
-{
- shutdownHaskell();
- stg_exit(EXIT_FAILURE);
-}
-
/* -----------------------------------------------------------------------------
Stack overflow
void
stackOverflow(void)
{
- StackOverflowHook(RtsFlags.GcFlags.maxStkSize * sizeof(W_));
+ StackOverflowHook(RtsFlags.GcFlags.maxStkSize * sizeof(W_));
#if defined(TICKY_TICKY)
- if (RtsFlags.TickyFlags.showTickyStats) PrintTickyInfo();
+ if (RtsFlags.TickyFlags.showTickyStats) PrintTickyInfo();
#endif
}
void
heapOverflow(void)
{
- fflush(stdout);
- OutOfHeapHook(0/*unknown request size*/,
- RtsFlags.GcFlags.maxHeapSize * BLOCK_SIZE);
-
+ /* don't fflush(stdout); WORKAROUND bug in Linux glibc */
+ OutOfHeapHook(0/*unknown request size*/,
+ RtsFlags.GcFlags.maxHeapSize * BLOCK_SIZE);
+
#if defined(TICKY_TICKY)
- if (RtsFlags.TickyFlags.showTickyStats) PrintTickyInfo();
+ if (RtsFlags.TickyFlags.showTickyStats) PrintTickyInfo();
#endif
- stg_exit(EXIT_FAILURE);
+ stg_exit(EXIT_FAILURE);
}
/* -----------------------------------------------------------------------------
/* -----------------------------------------------------------------------------
- * $Id: Schedule.c,v 1.23 1999/08/25 10:23:53 simonmar Exp $
+ * $Id: Schedule.c,v 1.24 1999/08/25 16:11:51 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
SET_INFO(tso,&TSO_info);
tso->whatNext = ThreadEnterGHC;
tso->id = next_thread_id++;
- tso->blocked_on = NULL;
+ tso->why_blocked = NotBlocked;
tso->splim = (P_)&(tso->stack) + RESERVED_STACK_WORDS;
tso->stack_size = stack_size;
/* If we have more threads on the run queue, set up a context
* switch at some point in the future.
*/
- if (run_queue_hd != END_TSO_QUEUE) {
+ if (run_queue_hd != END_TSO_QUEUE || blocked_queue_hd != END_TSO_QUEUE) {
context_switch = 1;
} else {
context_switch = 0;
break;
case ThreadBlocked:
- IF_DEBUG(scheduler,belch("Thread %ld stopped, blocking\n", t->id));
+ IF_DEBUG(scheduler,
+ fprintf(stderr, "Thread %d stopped, ", t->id);
+ printThreadBlockage(t);
+ fprintf(stderr, "\n"));
threadPaused(t);
/* assume the thread has put itself on some blocked queue
* somewhere.
}
next_thread:
+ /* Checked whether any waiting threads need to be woken up.
+ * If the run queue is empty, we can wait indefinitely for
+ * something to happen.
+ */
+ if (blocked_queue_hd != END_TSO_QUEUE) {
+ awaitEvent(run_queue_hd == END_TSO_QUEUE);
+ }
+
t = run_queue_hd;
if (t != END_TSO_QUEUE) {
run_queue_hd = t->link;
}
}
- if (blocked_queue_hd != END_TSO_QUEUE) {
- return AllBlocked;
- } else {
- return Deadlock;
+ /* If we got to here, then we ran out of threads to run, but the
+ * main thread hasn't finished yet. It must be blocked on an MVar
+ * or a black hole somewhere, so we return deadlock.
+ */
+ return Deadlock;
+}
+
+/* -----------------------------------------------------------------------------
+ Debugging: why is a thread blocked
+ -------------------------------------------------------------------------- */
+
+#ifdef DEBUG
+void printThreadBlockage(StgTSO *tso)
+{
+ switch (tso->why_blocked) {
+ case BlockedOnRead:
+ fprintf(stderr,"blocked on read from fd %d", tso->block_info.fd);
+ break;
+ case BlockedOnWrite:
+ fprintf(stderr,"blocked on write to fd %d", tso->block_info.fd);
+ break;
+ case BlockedOnDelay:
+ fprintf(stderr,"blocked on delay of %d ms", tso->block_info.delay);
+ break;
+ case BlockedOnMVar:
+ fprintf(stderr,"blocked on an MVar");
+ break;
+ case BlockedOnBlackHole:
+ fprintf(stderr,"blocked on a black hole");
+ break;
+ case NotBlocked:
+ fprintf(stderr,"not blocked");
+ break;
}
}
+#endif
/* -----------------------------------------------------------------------------
Where are the roots that we know about?
tso->whatNext = ThreadKilled;
tso->sp = (P_)&(tso->stack[tso->stack_size]);
tso->su = (StgUpdateFrame *)tso->sp;
- tso->blocked_on = NULL;
+ tso->why_blocked = NotBlocked;
dest->mut_link = NULL;
IF_DEBUG(sanity,checkTSO(tso));
}
/* -----------------------------------------------------------------------------
- Wake up a queue that was blocked on some resource (usually a
- computation in progress).
+ Wake up a queue that was blocked on some resource.
-------------------------------------------------------------------------- */
-void awaken_blocked_queue(StgTSO *q)
+StgTSO *unblockOne(StgTSO *tso)
{
- StgTSO *tso;
+ StgTSO *next;
+
+ ASSERT(get_itbl(tso)->type == TSO);
+ ASSERT(tso->why_blocked != NotBlocked);
+ tso->why_blocked = NotBlocked;
+ next = tso->link;
+ PUSH_ON_RUN_QUEUE(tso);
+ IF_DEBUG(scheduler,belch("Waking up thread %ld", tso->id));
+ return next;
+}
- while (q != END_TSO_QUEUE) {
- ASSERT(get_itbl(q)->type == TSO);
- tso = q;
- q = tso->link;
- PUSH_ON_RUN_QUEUE(tso);
- tso->blocked_on = NULL;
- IF_DEBUG(scheduler,belch("Waking up thread %ld", tso->id));
+void awakenBlockedQueue(StgTSO *tso)
+{
+ while (tso != END_TSO_QUEUE) {
+ tso = unblockOne(tso);
}
}
{
StgTSO *t, **last;
- if (tso->blocked_on == NULL) {
- return; /* not blocked */
- }
+ switch (tso->why_blocked) {
- switch (get_itbl(tso->blocked_on)->type) {
+ case NotBlocked:
+ return; /* not blocked */
- case MVAR:
+ case BlockedOnMVar:
+ ASSERT(get_itbl(tso->block_info.closure)->type == MVAR);
{
StgTSO *last_tso = END_TSO_QUEUE;
- StgMVar *mvar = (StgMVar *)(tso->blocked_on);
+ StgMVar *mvar = (StgMVar *)(tso->block_info.closure);
last = &mvar->head;
for (t = mvar->head; t != END_TSO_QUEUE;
barf("unblockThread (MVAR): TSO not found");
}
- case BLACKHOLE_BQ:
+ case BlockedOnBlackHole:
+ ASSERT(get_itbl(tso->block_info.closure)->type == BLACKHOLE_BQ);
{
- StgBlockingQueue *bq = (StgBlockingQueue *)(tso->blocked_on);
+ StgBlockingQueue *bq = (StgBlockingQueue *)(tso->block_info.closure);
last = &bq->blocking_queue;
for (t = bq->blocking_queue; t != END_TSO_QUEUE;
barf("unblockThread (BLACKHOLE): TSO not found");
}
+ case BlockedOnRead:
+ case BlockedOnWrite:
+ case BlockedOnDelay:
+ /* ToDo */
+ barf("unblockThread {read,write,delay}");
+
default:
barf("unblockThread");
}
done:
tso->link = END_TSO_QUEUE;
- tso->blocked_on = NULL;
+ tso->why_blocked = NotBlocked;
+ tso->block_info.closure = NULL;
PUSH_ON_RUN_QUEUE(tso);
}
/* -----------------------------------------------------------------------------
- * $Id: Schedule.h,v 1.5 1999/03/16 13:20:17 simonm Exp $
+ * $Id: Schedule.h,v 1.6 1999/08/25 16:11:51 simonmar Exp $
*
* (c) The GHC Team 1998-1999
*
* Miscellany
*/
-void awaken_blocked_queue(StgTSO *tso);
+void awakenBlockedQueue(StgTSO *tso);
+StgTSO *unblockOne(StgTSO *tso);
void initThread(StgTSO *tso, nat stack_size);
void interruptStgRts(void);
void raiseAsync(StgTSO *tso, StgClosure *exception);
extern nat context_switch;
+void awaitEvent(rtsBool wait); /* In Select.c */
+extern nat ticks_since_select; /* ditto */
+
extern StgTSO *run_queue_hd, *run_queue_tl;
extern StgTSO *blocked_queue_hd, *blocked_queue_tl;
+#ifdef DEBUG
+extern void printThreadBlockage(StgTSO *tso);
+#endif
+
#ifdef COMPILING_RTS_MAIN
extern DLLIMPORT StgTSO *MainTSO; /* temporary hack */
#else
} \
run_queue_tl = tso;
+#define PUSH_ON_BLOCKED_QUEUE(tso) \
+ if (blocked_queue_hd == END_TSO_QUEUE) { \
+ blocked_queue_hd = tso; \
+ } else { \
+ blocked_queue_tl->link = tso; \
+ } \
+ blocked_queue_tl = tso;
+
#define END_CAF_LIST stgCast(StgCAF*,(void*)&END_TSO_QUEUE_closure)
/* -----------------------------------------------------------------------------
- * $Id: StgMiscClosures.hc,v 1.26 1999/07/06 16:40:27 sewardj Exp $
+ * $Id: StgMiscClosures.hc,v 1.27 1999/08/25 16:11:51 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
/* ToDo: make the printing of panics more Win32-friendly, i.e.,
* pop up some lovely message boxes (as well).
*/
-#define DUMP_ERRMSG(msg) STGCALL1(fflush,stdout); STGCALL2(fprintf,stderr,msg)
+#define DUMP_ERRMSG(msg) STGCALL2(fprintf,stderr,msg)
/* -----------------------------------------------------------------------------
Entry code for an indirection.
/* Put ourselves on the blocking queue for this black hole */
CurrentTSO->link = (StgTSO *)&END_TSO_QUEUE_closure;
((StgBlockingQueue *)R1.p)->blocking_queue = CurrentTSO;
- CurrentTSO->blocked_on = R1.cl;
+ CurrentTSO->why_blocked = BlockedOnBlackHole;
+ CurrentTSO->block_info.closure = R1.cl;
recordMutable((StgMutClosure *)R1.cl);
/* stg_gen_block is too heavyweight, use a specialised one */
TICK_ENT_BH();
/* Put ourselves on the blocking queue for this black hole */
- CurrentTSO->blocked_on = R1.cl;
+ CurrentTSO->why_blocked = BlockedOnBlackHole;
+ CurrentTSO->block_info.closure = R1.cl;
CurrentTSO->link = ((StgBlockingQueue *)R1.p)->blocking_queue;
((StgBlockingQueue *)R1.p)->blocking_queue = CurrentTSO;
STGFUN(CAF_BLACKHOLE_entry)
{
FB_
- TICK_ENT_BH();
-
- /* Change the BLACKHOLE into a BLACKHOLE_BQ */
- ((StgBlockingQueue *)R1.p)->header.info = &BLACKHOLE_BQ_info;
- /* Put ourselves on the blocking queue for this black hole */
- CurrentTSO->link = (StgTSO *)&END_TSO_QUEUE_closure;
- ((StgBlockingQueue *)R1.p)->blocking_queue = CurrentTSO;
- CurrentTSO->blocked_on = R1.cl;
- recordMutable((StgMutClosure *)R1.cl);
-
- /* stg_gen_block is too heavyweight, use a specialised one */
- BLOCK_NP(1);
+ JMP_(BLACKHOLE_entry);
FE_
}
STGFUN(SE_BLACKHOLE_entry)
{
FB_
- STGCALL1(fflush,stdout);
STGCALL3(fprintf,stderr,"SE_BLACKHOLE at %p entered!\n",R1.p);
- STGCALL1(raiseError, errorHandler);
- stg_exit(EXIT_FAILURE); /* not executed */
+ STGCALL1(shutdownHaskellAndExit,EXIT_FAILURE);
FE_
}
STGFUN(SE_CAF_BLACKHOLE_entry)
{
FB_
- STGCALL1(fflush,stdout);
STGCALL3(fprintf,stderr,"SE_CAF_BLACKHOLE at %p entered!\n",R1.p);
- STGCALL1(raiseError, errorHandler);
- stg_exit(EXIT_FAILURE); /* not executed */
+ STGCALL1(shutdownHaskellAndExit,EXIT_FAILURE);
FE_
}
#endif
{ \
FB_ \
DUMP_ERRMSG(#type " object entered!\n"); \
- STGCALL1(raiseError, errorHandler); \
- stg_exit(EXIT_FAILURE); /* not executed */ \
+ STGCALL1(shutdownHaskellAndExit, EXIT_FAILURE); \
FE_ \
}
{ \
FB_ \
DUMP_ERRMSG("fatal: stg_error_entry"); \
- STGCALL1(raiseError, errorHandler); \
- exit(EXIT_FAILURE); /* not executed */ \
+ STGCALL1(shutdownHaskellAndExit, EXIT_FAILURE); \
FE_ \
}
projects / ghc-hetmet.git / commitdiff