From c6ab4bfa09886be3bfff4aa747af2f1c8e348a1f Mon Sep 17 00:00:00 2001
From: simonmar <unknown>
Date: Wed, 25 Aug 1999 16:11:56 +0000
Subject: [PATCH] [project @ 1999-08-25 16:11:43 by simonmar] Support for
thread{WaitRead,WaitWrite,Delay}. These should behave identically to the
3.02 implementations.
We now have the virtual timer on during all program runs, which ticks
at 50Hz by default. This is used to implement threadDelay, so you
won't get any better granularity than the tick frequency
unfortunately. It remains to be seen whether using the virtual timer
will have a measurable impact on performance for non-threadDelaying
programs.
All operations in the I/O subsystem should now be non-blocking with
respect to other running Haskell threads. It remains to be seen
whether this will have a measurable performance impact on
non-concurrent programs (probably not).
---
ghc/includes/PrimOps.h | 6 +-
ghc/includes/Rts.h | 4 +-
ghc/includes/TSO.h | 28 +++++++-
ghc/includes/Updates.h | 6 +-
ghc/lib/concurrent/Concurrent.lhs | 7 +-
ghc/rts/GC.c | 17 +++--
ghc/rts/HeapStackCheck.h | 10 +++
ghc/rts/HeapStackCheck.hc | 28 ++++----
ghc/rts/Itimer.c | 39 +++++++++--
ghc/rts/Itimer.h | 11 +--
ghc/rts/PrimOps.hc | 64 ++++++++++++++---
ghc/rts/ProfRts.h | 5 +-
ghc/rts/Profiling.c | 20 +++---
ghc/rts/Proftimer.c | 29 +-------
ghc/rts/Proftimer.h | 4 +-
ghc/rts/RtsFlags.c | 33 +--------
ghc/rts/RtsFlags.h | 4 +-
ghc/rts/RtsStartup.c | 14 +++-
ghc/rts/RtsUtils.c | 37 ++++------
ghc/rts/Schedule.c | 112 ++++++++++++++++++++++--------
ghc/rts/Schedule.h | 20 +++++-
ghc/rts/StgMiscClosures.hc | 37 +++-------
22 files changed, 324 insertions(+), 211 deletions(-)
diff --git a/ghc/includes/PrimOps.h b/ghc/includes/PrimOps.h
index 6dd2209ec9d1..77e74c3d409b 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 77f095cc745f..1dc23dd37474 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 dd568bd148b9..2c53ab9b6751 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 753da3c8d1ae..e142cd0e9ec1 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 de342c6e4328..befeaa64ec7d 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 b32274f235e4..7d299beefae0 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 3a5e2e4d64c4..1f2efeefb9c4 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 e387b0638564..8f66e92e30ce 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 5ec8c0d92a4b..bbbb3adebea3 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 0876e8445353..fbdf795c8bff 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 84ecf27840ee..08ca10a6cd9d 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 2634f7a623e5..9c438f2f7b80 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 56260b1d194a..aa11286cf101 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 b93123a78406..ad5bbd92072c 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 1e1a090e8551..38a023ca12be 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 3c2af6c2f7f1..1615934b1973 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 a0e6205df61a..9e7f70c8561c 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 d87f18862a53..f6aaebd080a2 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 aab8a38008c1..d3d01cfb1ec5 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 70df69675272..8450d9729988 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 6bdde63fa0ef..4a2cac0f44ec 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 10d8cd0d6774..671177fef96e 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_ \
}
--
GitLab