diff --git a/ghc/includes/PrimOps.h b/ghc/includes/PrimOps.h
index 6dd2209ec9d10bd4fd432f38310b28a85b85c392..77e74c3d409b94a7325a373c6a2b16f894372ad4 100644
--- a/ghc/includes/PrimOps.h
+++ b/ghc/includes/PrimOps.h
@@ -1,5 +1,5 @@
/* -----------------------------------------------------------------------------
- * $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
*
@@ -663,7 +663,9 @@ EF_(putMVarzh_fast);
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
diff --git a/ghc/includes/Rts.h b/ghc/includes/Rts.h
index 77f095cc745fe064c4131bbd16c9e94166fe4e6b..1dc23dd37474b0eae52f78bdbab0ff0ce2d05f76 100644
--- a/ghc/includes/Rts.h
+++ b/ghc/includes/Rts.h
@@ -1,5 +1,5 @@
/* -----------------------------------------------------------------------------
- * $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
*
@@ -85,6 +85,4 @@ typedef enum {
#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
diff --git a/ghc/includes/TSO.h b/ghc/includes/TSO.h
index dd568bd148b9f3d440eaa5e728ee7e977a74c1d0..2c53ab9b67517cda13caf46cb3e92b1c7511d9ca 100644
--- a/ghc/includes/TSO.h
+++ b/ghc/includes/TSO.h
@@ -1,5 +1,5 @@
/* -----------------------------------------------------------------------------
- * $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
*
@@ -70,6 +70,29 @@ typedef enum {
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
@@ -81,7 +104,8 @@ typedef struct StgTSO_ {
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;
diff --git a/ghc/includes/Updates.h b/ghc/includes/Updates.h
index 753da3c8d1aed9bf424ba76afff37c41a0f4522c..e142cd0e9ec1c52e1728160352aae73f7de83755 100644
--- a/ghc/includes/Updates.h
+++ b/ghc/includes/Updates.h
@@ -1,5 +1,5 @@
/* -----------------------------------------------------------------------------
- * $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
*
@@ -51,13 +51,13 @@
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); \
} \
}
diff --git a/ghc/lib/concurrent/Concurrent.lhs b/ghc/lib/concurrent/Concurrent.lhs
index de342c6e4328e555dce6def635a7ff0649e326c2..befeaa64ec7da90f5308018f6bab3a1e4174ec7c 100644
--- a/ghc/lib/concurrent/Concurrent.lhs
+++ b/ghc/lib/concurrent/Concurrent.lhs
@@ -31,7 +31,9 @@ module Concurrent (
, fork -- :: a -> b -> b
, yield -- :: IO ()
- {-threadDelay, threadWaitRead, threadWaitWrite,-}
+ , threadDelay -- :: Int -> IO ()
+ , threadWaitRead -- :: Int -> IO ()
+ , threadWaitWrite -- :: Int -> IO ()
-- MVars
, MVar -- abstract
@@ -54,7 +56,8 @@ import Channel
import Semaphore
import SampleVar
import PrelConc
-import PrelHandle ( topHandler )
+import PrelHandle ( topHandler, threadDelay,
+ threadWaitRead, threadWaitWrite )
import PrelException
import PrelIOBase ( IO(..) )
import IO
diff --git a/ghc/rts/GC.c b/ghc/rts/GC.c
index b32274f235e462f9206ccce8edcd8245ca6d7ddb..7d299beefae0411e46ce37fff996194083940ad4 100644
--- a/ghc/rts/GC.c
+++ b/ghc/rts/GC.c
@@ -1,5 +1,5 @@
/* -----------------------------------------------------------------------------
- * $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
*
@@ -1842,8 +1842,9 @@ scavenge(step *step)
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]));
@@ -2195,8 +2196,9 @@ scavenge_mutable_list(generation *gen)
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]));
@@ -2571,8 +2573,9 @@ scavenge_large(step *step)
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]));
diff --git a/ghc/rts/HeapStackCheck.h b/ghc/rts/HeapStackCheck.h
index 3a5e2e4d64c47f3f0968fd971e401ed539e834a9..1f2efeefb9c404d2ac103e45a033bb06f3c82481 100644
--- a/ghc/rts/HeapStackCheck.h
+++ b/ghc/rts/HeapStackCheck.h
@@ -1,3 +1,12 @@
+/* -----------------------------------------------------------------------------
+ * $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);
@@ -38,4 +47,5 @@ EXTFUN(stg_gen_yield);
EXTFUN(stg_yield_noregs);
EXTFUN(stg_yield_to_Hugs);
EXTFUN(stg_gen_block);
+EXTFUN(stg_block_noregs);
EXTFUN(stg_block_1);
diff --git a/ghc/rts/HeapStackCheck.hc b/ghc/rts/HeapStackCheck.hc
index e387b0638564bea6474798db427189b45c4db176..8f66e92e30ce8d88771226490e14015f5096e983 100644
--- a/ghc/rts/HeapStackCheck.hc
+++ b/ghc/rts/HeapStackCheck.hc
@@ -1,5 +1,5 @@
/* -----------------------------------------------------------------------------
- * $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
*
@@ -295,6 +295,10 @@ EXTFUN(stg_gc_seq_1)
/*-- 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);
@@ -823,22 +827,11 @@ FN_(stg_gen_yield)
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_
}
@@ -863,6 +856,15 @@ FN_(stg_gen_block)
FE_
}
+FN_(stg_block_noregs)
+{
+ FB_
+ Sp--;
+ Sp[0] = (W_)&stg_gc_noregs_ret_info;
+ BLOCK_GENERIC;
+ FE_
+}
+
FN_(stg_block_1)
{
FB_
diff --git a/ghc/rts/Itimer.c b/ghc/rts/Itimer.c
index 5ec8c0d92a4bc1afc1f311dcd84d148156d10d89..bbbb3adebea3a4f66d5431c8ddb5b010f1181cb2 100644
--- a/ghc/rts/Itimer.c
+++ b/ghc/rts/Itimer.c
@@ -1,5 +1,5 @@
/* -----------------------------------------------------------------------------
- * $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
*
@@ -24,6 +24,7 @@
#include "Rts.h"
#include "Itimer.h"
+#include "Schedule.h"
/* As recommended in the autoconf manual */
# ifdef TIME_WITH_SYS_TIME
@@ -41,6 +42,34 @@
# 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
@@ -132,19 +161,19 @@ initialize_virtual_timer(nat ms)
#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;
diff --git a/ghc/rts/Itimer.h b/ghc/rts/Itimer.h
index 0876e8445353ad21fbf99a65265c067e93f25c96..fbdf795c8bffed1b22ba270c6688a4d229d8d94b 100644
--- a/ghc/rts/Itimer.h
+++ b/ghc/rts/Itimer.h
@@ -1,5 +1,5 @@
/* -----------------------------------------------------------------------------
- * $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
*
@@ -7,9 +7,12 @@
*
* ---------------------------------------------------------------------------*/
+# 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 );
-
-
diff --git a/ghc/rts/PrimOps.hc b/ghc/rts/PrimOps.hc
index 84ecf27840eef35e6f7d4553a3d30cd204a07813..08ca10a6cd9d7cebaf255623c54a80075e20b020 100644
--- a/ghc/rts/PrimOps.hc
+++ b/ghc/rts/PrimOps.hc
@@ -1,5 +1,5 @@
/* -----------------------------------------------------------------------------
- * $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
*
@@ -842,7 +842,8 @@ FN_(takeMVarzh_fast)
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);
@@ -860,7 +861,6 @@ FN_(takeMVarzh_fast)
FN_(putMVarzh_fast)
{
StgMVar *mvar;
- StgTSO *tso;
FB_
/* args: R1 = MVar, R2 = value */
@@ -874,15 +874,12 @@ FN_(putMVarzh_fast)
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;
}
@@ -924,5 +921,50 @@ FN_(makeStableNamezh_fast)
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 */
diff --git a/ghc/rts/ProfRts.h b/ghc/rts/ProfRts.h
index 2634f7a623e569695f872e76cbea0482561e0dbc..9c438f2f7b803d27d2bb27bcaf2aa2ff4500a648 100644
--- a/ghc/rts/ProfRts.h
+++ b/ghc/rts/ProfRts.h
@@ -1,5 +1,5 @@
/* -----------------------------------------------------------------------------
- * $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
*
@@ -23,9 +23,6 @@ void print_ccs (FILE *, CostCentreStack *);
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;
diff --git a/ghc/rts/Profiling.c b/ghc/rts/Profiling.c
index 56260b1d194a5771b3892a5c5e37c4ade209f28f..aa11286cf101351119b0a230637c5f8013e9c429 100644
--- a/ghc/rts/Profiling.c
+++ b/ghc/rts/Profiling.c
@@ -1,5 +1,5 @@
/* -----------------------------------------------------------------------------
- * $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
*
@@ -45,7 +45,7 @@ rtsBool time_profiling = rtsFalse;
/* 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
*/
@@ -183,9 +183,7 @@ initProfiling (void)
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();
};
@@ -196,7 +194,7 @@ endProfiling ( void )
}
void
-heapCensus ( bdescr *bd UNUSED )
+heapCensus ( bdescr *bd STG_UNUSED )
{
/* nothing yet */
}
@@ -512,7 +510,7 @@ report_ccs_profiling( void )
stopProfTimer();
- total_ticks = 0;
+ total_prof_ticks = 0;
total_alloc = 0;
count_ticks(CCS_MAIN);
@@ -535,8 +533,8 @@ report_ccs_profiling( void )
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_),
@@ -596,7 +594,7 @@ reportCCS(CostCentreStack *ccs, nat indent)
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);
@@ -628,7 +626,7 @@ count_ticks(CostCentreStack *ccs)
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);
diff --git a/ghc/rts/Proftimer.c b/ghc/rts/Proftimer.c
index b93123a784061bcb0ec8b9aa373c0f7e9a25cfa5..ad5bbd92072c7235f9b955d5c0784e1a71ab4e5f 100644
--- a/ghc/rts/Proftimer.c
+++ b/ghc/rts/Proftimer.c
@@ -1,5 +1,5 @@
/* -----------------------------------------------------------------------------
- * $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
*
@@ -16,8 +16,6 @@
#include "Itimer.h"
#include "Proftimer.h"
-lnat total_ticks = 0;
-
nat current_interval = 1; /* Current interval number --
stored in AGE */
@@ -26,21 +24,11 @@ nat interval_ticks = DEFAULT_INTERVAL; /* No of ticks in an interval */
nat previous_ticks = 0; /* ticks in previous intervals */
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;
}
};
@@ -48,19 +36,8 @@ void
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 */
diff --git a/ghc/rts/Proftimer.h b/ghc/rts/Proftimer.h
index 1e1a090e8551cd2ad16dd0b4f35c3cc75bf22f78..38a023ca12bea6fe3e6cf1841a944a809335ab20 100644
--- a/ghc/rts/Proftimer.h
+++ b/ghc/rts/Proftimer.h
@@ -1,5 +1,5 @@
/* -----------------------------------------------------------------------------
- * $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
*
@@ -7,6 +7,8 @@
*
* ---------------------------------------------------------------------------*/
+extern lnat total_prof_ticks;
+
extern void initProfTimer(nat ms);
extern void stopProfTimer(void);
extern void startProfTimer(void);
diff --git a/ghc/rts/RtsFlags.c b/ghc/rts/RtsFlags.c
index 3c2af6c2f7f16a2e4be580067c4866b385a8dee3..1615934b1973a54d32e09a1c5db80d4615125f3b 100644
--- a/ghc/rts/RtsFlags.c
+++ b/ghc/rts/RtsFlags.c
@@ -1,5 +1,5 @@
/* -----------------------------------------------------------------------------
- * $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
@@ -97,23 +97,7 @@ void initRtsFlagsDefaults(void)
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;
@@ -279,16 +263,11 @@ usage_text[] = {
" -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",
@@ -735,16 +714,6 @@ error = rtsTrue;
}
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(
diff --git a/ghc/rts/RtsFlags.h b/ghc/rts/RtsFlags.h
index a0e6205df61aee3b1668fd313aff23374b776bec..9e7f70c8561c9fa14a19bd6d9ec2a77043838aaa 100644
--- a/ghc/rts/RtsFlags.h
+++ b/ghc/rts/RtsFlags.h
@@ -1,5 +1,5 @@
/* -----------------------------------------------------------------------------
- * $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
*
@@ -85,6 +85,7 @@ struct COST_CENTRE_FLAGS {
#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
@@ -118,7 +119,6 @@ struct PROFILING_FLAGS {
struct CONCURRENT_FLAGS {
int ctxtSwitchTime; /* in milliseconds */
- int maxThreads;
};
#ifdef PAR
diff --git a/ghc/rts/RtsStartup.c b/ghc/rts/RtsStartup.c
index d87f18862a53548d3f8eafda35aff7b2d17d99d9..f6aaebd080a2855024261eab66611209f7e970a6 100644
--- a/ghc/rts/RtsStartup.c
+++ b/ghc/rts/RtsStartup.c
@@ -1,5 +1,5 @@
/* -----------------------------------------------------------------------------
- * $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
*
@@ -15,6 +15,8 @@
#include "StablePriv.h" /* initStablePtrTable */
#include "Schedule.h" /* initScheduler */
#include "Stats.h" /* initStats */
+#include "Signals.h"
+#include "Itimer.h"
#include "Weak.h"
#include "Ticky.h"
@@ -110,15 +112,18 @@ startupHaskell(int argc, char *argv[])
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
@@ -171,6 +176,9 @@ shutdownHaskell(void)
/* 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
diff --git a/ghc/rts/RtsUtils.c b/ghc/rts/RtsUtils.c
index aab8a38008c14339144dcd9e7404c4b36fce35f4..d3d01cfb1ec5b7d742ed387705de7019258b6547 100644
--- a/ghc/rts/RtsUtils.c
+++ b/ghc/rts/RtsUtils.c
@@ -1,5 +1,5 @@
/* -----------------------------------------------------------------------------
- * $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
*
@@ -27,7 +27,7 @@ void barf(char *s, ...)
{
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 {
@@ -43,7 +43,7 @@ void belch(char *s, ...)
{
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");
}
@@ -56,7 +56,7 @@ stgMallocBytes (int n, char *msg)
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);
}
@@ -69,7 +69,7 @@ stgReallocBytes (void *p, int n, char *msg)
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);
}
@@ -91,20 +91,11 @@ stgReallocWords (void *p, int n, char *msg)
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
@@ -114,25 +105,25 @@ raiseError( StgStablePtr handler STG_UNUSED )
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);
}
/* -----------------------------------------------------------------------------
diff --git a/ghc/rts/Schedule.c b/ghc/rts/Schedule.c
index 70df69675272937e55978bb45bbd2af920c2efbd..8450d972998813e2ee31c99abffb52b4af3ae40e 100644
--- a/ghc/rts/Schedule.c
+++ b/ghc/rts/Schedule.c
@@ -1,5 +1,5 @@
/* -----------------------------------------------------------------------------
- * $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
*
@@ -127,7 +127,7 @@ initThread(StgTSO *tso, nat stack_size)
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;
@@ -260,7 +260,7 @@ SchedulerStatus schedule(StgTSO *main, StgClosure **ret_val)
/* 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;
@@ -392,7 +392,10 @@ SchedulerStatus schedule(StgTSO *main, StgClosure **ret_val)
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.
@@ -438,6 +441,14 @@ SchedulerStatus schedule(StgTSO *main, StgClosure **ret_val)
}
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;
@@ -448,12 +459,42 @@ SchedulerStatus schedule(StgTSO *main, StgClosure **ret_val)
}
}
- 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?
@@ -588,7 +629,7 @@ threadStackOverflow(StgTSO *tso)
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));
@@ -602,21 +643,26 @@ threadStackOverflow(StgTSO *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);
}
}
@@ -644,16 +690,16 @@ unblockThread(StgTSO *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;
@@ -669,9 +715,10 @@ unblockThread(StgTSO *tso)
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;
@@ -684,13 +731,20 @@ unblockThread(StgTSO *tso)
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);
}
diff --git a/ghc/rts/Schedule.h b/ghc/rts/Schedule.h
index 6bdde63fa0efc2474603023ff38dbab79a990920..4a2cac0f44ecb5d3248382cf65d4b00d7594de2d 100644
--- a/ghc/rts/Schedule.h
+++ b/ghc/rts/Schedule.h
@@ -1,5 +1,5 @@
/* -----------------------------------------------------------------------------
- * $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
*
@@ -18,16 +18,24 @@ void initScheduler(void);
* 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
@@ -43,4 +51,12 @@ extern StgTSO *MainTSO; /* temporary hack */
} \
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)
diff --git a/ghc/rts/StgMiscClosures.hc b/ghc/rts/StgMiscClosures.hc
index 10d8cd0d6774eaf06456cdc278819360c66d5172..671177fef96e826a29ed56a363cb8294ada081ee 100644
--- a/ghc/rts/StgMiscClosures.hc
+++ b/ghc/rts/StgMiscClosures.hc
@@ -1,5 +1,5 @@
/* -----------------------------------------------------------------------------
- * $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
*
@@ -22,7 +22,7 @@
/* 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.
@@ -190,7 +190,8 @@ STGFUN(BLACKHOLE_entry)
/* 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 */
@@ -205,7 +206,8 @@ STGFUN(BLACKHOLE_BQ_entry)
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;
@@ -219,18 +221,7 @@ INFO_TABLE(CAF_BLACKHOLE_info, CAF_BLACKHOLE_entry,0,2,CAF_BLACKHOLE,,EF_,0,0);
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_
}
@@ -239,10 +230,8 @@ INFO_TABLE(SE_BLACKHOLE_info, SE_BLACKHOLE_entry,0,2,SE_BLACKHOLE,,EF_,0,0);
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_
}
@@ -250,10 +239,8 @@ INFO_TABLE(SE_CAF_BLACKHOLE_info, SE_CAF_BLACKHOLE_entry,0,2,SE_CAF_BLACKHOLE,,E
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
@@ -280,8 +267,7 @@ STGFUN(type##_entry) \
{ \
FB_ \
DUMP_ERRMSG(#type " object entered!\n"); \
- STGCALL1(raiseError, errorHandler); \
- stg_exit(EXIT_FAILURE); /* not executed */ \
+ STGCALL1(shutdownHaskellAndExit, EXIT_FAILURE); \
FE_ \
}
@@ -425,8 +411,7 @@ STGFUN(stg_error_entry) \
{ \
FB_ \
DUMP_ERRMSG("fatal: stg_error_entry"); \
- STGCALL1(raiseError, errorHandler); \
- exit(EXIT_FAILURE); /* not executed */ \
+ STGCALL1(shutdownHaskellAndExit, EXIT_FAILURE); \
FE_ \
}