diff --git a/ghc/includes/ClosureTypes.h b/ghc/includes/ClosureTypes.h
index eb0a12a705448cbf82a897792edc75d6f185992d..d392b929d2a22d474cb284164c683e708113222f 100644
--- a/ghc/includes/ClosureTypes.h
+++ b/ghc/includes/ClosureTypes.h
@@ -1,5 +1,5 @@
/* ----------------------------------------------------------------------------
- * $Id: ClosureTypes.h,v 1.4 1999/01/14 16:57:07 simonm Exp $
+ * $Id: ClosureTypes.h,v 1.5 1999/01/15 17:57:03 simonm Exp $
*
* Closure Type Constants
*
@@ -46,17 +46,18 @@
#define STOP_FRAME 30
#define SEQ_FRAME 31
#define BLACKHOLE 32
-#define MVAR 33
-#define ARR_WORDS 34
-#define MUT_ARR_WORDS 35
-#define MUT_ARR_PTRS 36
-#define MUT_ARR_PTRS_FROZEN 37
-#define MUT_VAR 38
-#define WEAK 49
-#define FOREIGN 40
-#define TSO 41
-#define BLOCKED_FETCH 42
-#define FETCH_ME 43
-#define EVACUATED 44
+#define BLACKHOLE_BQ 33
+#define MVAR 34
+#define ARR_WORDS 35
+#define MUT_ARR_WORDS 36
+#define MUT_ARR_PTRS 37
+#define MUT_ARR_PTRS_FROZEN 38
+#define MUT_VAR 49
+#define WEAK 40
+#define FOREIGN 41
+#define TSO 42
+#define BLOCKED_FETCH 43
+#define FETCH_ME 44
+#define EVACUATED 45
#endif CLOSURETYPES_H
diff --git a/ghc/includes/InfoTables.h b/ghc/includes/InfoTables.h
index 20950267ce1c328d1d0063b9ec5d8dcb6968a3a8..fb7c65faa1b23ac3b555478baad7ef33b3d9a58a 100644
--- a/ghc/includes/InfoTables.h
+++ b/ghc/includes/InfoTables.h
@@ -1,5 +1,5 @@
/* ----------------------------------------------------------------------------
- * $Id: InfoTables.h,v 1.3 1999/01/13 17:25:53 simonm Exp $
+ * $Id: InfoTables.h,v 1.4 1999/01/15 17:57:03 simonm Exp $
*
* Info Tables
*
@@ -127,13 +127,16 @@ typedef enum {
, SEQ_FRAME
, BLACKHOLE
+ , BLACKHOLE_BQ
+
, MVAR
, ARR_WORDS
-
, MUT_ARR_WORDS
+
, MUT_ARR_PTRS
, MUT_ARR_PTRS_FROZEN
+
, MUT_VAR
, WEAK
@@ -199,6 +202,7 @@ typedef enum {
#define FLAGS_FOREIGN (_HNF| _NS| _UPT )
#define FLAGS_WEAK (_HNF| _NS| _UPT )
#define FLAGS_BLACKHOLE ( _NS| _UPT )
+#define FLAGS_BLACKHOLE_BQ ( _NS| _UPT )
#define FLAGS_MVAR (_HNF| _NS| _MUT|_UPT )
#define FLAGS_FETCH_ME (_HNF| _NS )
#define FLAGS_TSO (_HNF| _NS| _MUT|_UPT )
diff --git a/ghc/includes/StgMiscClosures.h b/ghc/includes/StgMiscClosures.h
index a313a4d71409e666dd53f033fca70773acbe912e..0598ccd942e411149a908139a6606301db0ae524 100644
--- a/ghc/includes/StgMiscClosures.h
+++ b/ghc/includes/StgMiscClosures.h
@@ -1,5 +1,5 @@
/* -----------------------------------------------------------------------------
- * $Id: StgMiscClosures.h,v 1.4 1999/01/15 12:47:19 sewardj Exp $
+ * $Id: StgMiscClosures.h,v 1.5 1999/01/15 17:57:04 simonm Exp $
*
* Entry code for various built-in closure types.
*
@@ -21,6 +21,7 @@ STGFUN(CAF_UNENTERED_entry);
STGFUN(CAF_ENTERED_entry);
STGFUN(CAF_BLACKHOLE_entry);
STGFUN(BLACKHOLE_entry);
+STGFUN(BLACKHOLE_BQ_entry);
STGFUN(BCO_entry);
STGFUN(EVACUATED_entry);
STGFUN(FOREIGN_entry);
@@ -50,6 +51,7 @@ extern const StgInfoTable CAF_UNENTERED_info;
extern const StgInfoTable CAF_ENTERED_info;
extern const StgInfoTable CAF_BLACKHOLE_info;
extern const StgInfoTable BLACKHOLE_info;
+extern const StgInfoTable BLACKHOLE_BQ_info;
extern const StgInfoTable BCO_info;
extern const StgInfoTable EVACUATED_info;
extern const StgInfoTable FOREIGN_info;
diff --git a/ghc/includes/Updates.h b/ghc/includes/Updates.h
index 3a599c220b8c563c2a107897204c67803f031297..9ad4128f9cc6aeec85004f9bac097308ef3aa7ce 100644
--- a/ghc/includes/Updates.h
+++ b/ghc/includes/Updates.h
@@ -1,5 +1,5 @@
/* -----------------------------------------------------------------------------
- * $Id: Updates.h,v 1.3 1999/01/13 17:25:55 simonm Exp $
+ * $Id: Updates.h,v 1.4 1999/01/15 17:57:04 simonm Exp $
*
* Definitions related to updates.
*
@@ -30,18 +30,6 @@
updateWithIndirection((StgClosure *)updclosure, \
(StgClosure *)heapptr);
-/* -----------------------------------------------------------------------------
- Update a closure inplace with an infotable that expects 1 (closure)
- argument.
- Also may wake up BQs.
- -------------------------------------------------------------------------- */
-
-#define UPD_INPLACE1(updclosure,info,c0) \
- TICK_UPDATED_SET_UPDATED(updclosure); \
- AWAKEN_BQ(updclosure); \
- SET_INFO(updclosure,info); \
- payloadCPtr(updclosure,0) = (c0)
-
/* -----------------------------------------------------------------------------
Awaken any threads waiting on this computation
-------------------------------------------------------------------------- */
@@ -49,7 +37,7 @@
extern void awaken_blocked_queue(StgTSO *q);
#define AWAKEN_BQ(closure) \
- if (closure->header.info == &BLACKHOLE_info) { \
+ if (closure->header.info == &BLACKHOLE_BQ_info) { \
StgTSO *bq = ((StgBlackHole *)closure)->blocking_queue; \
if (bq != (StgTSO *)&END_TSO_QUEUE_closure) { \
STGCALL1(awaken_blocked_queue, bq); \
@@ -111,8 +99,6 @@ extern void newCAF(StgClosure*);
{ \
SET_INFO((StgInd *)cafptr,&IND_STATIC_info); \
((StgInd *)cafptr)->indirectee = (StgClosure *)(bhptr); \
- ((StgBlackHole *)(bhptr))->blocking_queue = \
- (StgTSO *)&END_TSO_QUEUE_closure; \
STGCALL1(newCAF,(StgClosure *)cafptr); \
}
diff --git a/ghc/rts/DebugProf.c b/ghc/rts/DebugProf.c
index 7fe57ca913223d286116d52335a79cb823006fe9..f5ad811fb520d3c217134c98132ebd5d809bbfb4 100644
--- a/ghc/rts/DebugProf.c
+++ b/ghc/rts/DebugProf.c
@@ -1,5 +1,5 @@
/* -----------------------------------------------------------------------------
- * $Id: DebugProf.c,v 1.3 1999/01/13 17:25:38 simonm Exp $
+ * $Id: DebugProf.c,v 1.4 1999/01/15 17:57:05 simonm Exp $
*
* (c) The GHC Team 1998
*
@@ -157,6 +157,7 @@ static char *type_names[] = {
, "SEQ_FRAME"
, "BLACKHOLE"
+ , "BLACKHOLE_BQ"
, "MVAR"
, "ARR_WORDS"
@@ -282,6 +283,7 @@ heapCensus(bdescr *bd)
case IND_PERM:
case IND_OLDGEN_PERM:
case BLACKHOLE:
+ case BLACKHOLE_BQ:
case WEAK:
case FOREIGN:
case MVAR:
diff --git a/ghc/rts/Evaluator.c b/ghc/rts/Evaluator.c
index ce1003871fd7c3ed6f22d9530df1e70dcc9e46e6..b951f3cc200d583911f06f155e6c8470531d8739 100644
--- a/ghc/rts/Evaluator.c
+++ b/ghc/rts/Evaluator.c
@@ -5,8 +5,8 @@
* Copyright (c) 1994-1998.
*
* $RCSfile: Evaluator.c,v $
- * $Revision: 1.2 $
- * $Date: 1998/12/02 13:28:17 $
+ * $Revision: 1.3 $
+ * $Date: 1999/01/15 17:57:06 $
* ---------------------------------------------------------------------------*/
#include "Rts.h"
@@ -402,10 +402,20 @@ static inline void PopSeqFrame( void )
static inline StgClosure* raiseAnError( StgClosure* errObj )
{
+ StgClosure *raise_closure;
+
+ /* This closure represents the expression 'raise# E' where E
+ * is the exception raise. It is used to overwrite all the
+ * thunks which are currently under evaluataion.
+ */
+ raise_closure = (StgClosure *)allocate(sizeofW(StgClosure)+1);
+ raise_closure->header.info = &raise_info;
+ raise_closure->payload[0] = R1.cl;
+
while (1) {
switch (get_itbl(Su)->type) {
case UPDATE_FRAME:
- UPD_INPLACE1(Su->updatee,&raise_info,errObj);
+ UPD_IND(Su->updatee,raise_closure);
Sp = stgCast(StgStackPtr,Su) + sizeofW(StgUpdateFrame);
Su = Su->link;
break;
diff --git a/ghc/rts/GC.c b/ghc/rts/GC.c
index 741c46629bbebf4f940c18e3ef1a470895d66eca..afe200913039a23b679115e3aacd31a152b535b7 100644
--- a/ghc/rts/GC.c
+++ b/ghc/rts/GC.c
@@ -1,5 +1,5 @@
/* -----------------------------------------------------------------------------
- * $Id: GC.c,v 1.8 1999/01/14 11:11:29 simonm Exp $
+ * $Id: GC.c,v 1.9 1999/01/15 17:57:08 simonm Exp $
*
* Two-space garbage collector
*
@@ -926,7 +926,11 @@ loop:
case CAF_BLACKHOLE:
case BLACKHOLE:
- to = copy(q,BLACKHOLE_sizeW(),bd);
+ case BLACKHOLE_BQ:
+ /* ToDo: don't need to copy all the blackhole, some of it is
+ * just padding.
+ */
+ to = copy(q,BLACKHOLE_sizeW(),bd);
upd_evacuee(q,to);
return to;
@@ -994,6 +998,7 @@ loop:
case CAF_UNENTERED:
case CAF_BLACKHOLE:
case BLACKHOLE:
+ case BLACKHOLE_BQ:
/* not evaluated yet */
break;
@@ -1347,6 +1352,10 @@ scavenge(step *step)
case CAF_BLACKHOLE:
case BLACKHOLE:
+ p += BLACKHOLE_sizeW();
+ break;
+
+ case BLACKHOLE_BQ:
{
StgBlackHole *bh = (StgBlackHole *)p;
(StgClosure *)bh->blocking_queue =
@@ -1520,6 +1529,9 @@ scavenge_one(StgPtr p)
case CAF_BLACKHOLE:
case BLACKHOLE:
+ break;
+
+ case BLACKHOLE_BQ:
{
StgBlackHole *bh = (StgBlackHole *)p;
(StgClosure *)bh->blocking_queue =
@@ -1858,8 +1870,8 @@ scavenge_stack(StgPtr p, StgPtr stack_end)
goto follow_srt;
/* Specialised code for update frames, since they're so common.
- * We *know* the updatee points to a BLACKHOLE or CAF_BLACKHOLE,
- * so just inline the code to evacuate it here.
+ * We *know* the updatee points to a BLACKHOLE, CAF_BLACKHOLE,
+ * or BLACKHOLE_BQ, so just inline the code to evacuate it here.
*/
case UPDATE_FRAME:
{
@@ -1873,8 +1885,15 @@ scavenge_stack(StgPtr p, StgPtr stack_end)
continue;
} else {
bdescr *bd = Bdescr((P_)frame->updatee);
- ASSERT(type == BLACKHOLE || type == CAF_BLACKHOLE);
- if (bd->gen->no >= evac_gen && bd->gen->no > N) { continue; }
+ ASSERT(type == BLACKHOLE ||
+ type == CAF_BLACKHOLE ||
+ type == BLACKHOLE_BQ);
+ if (bd->gen->no > N) {
+ if (bd->gen->no < evac_gen) {
+ failed_to_evac = rtsTrue;
+ }
+ continue;
+ }
to = copy(frame->updatee, BLACKHOLE_sizeW(), bd);
upd_evacuee(frame->updatee,to);
frame->updatee = to;
@@ -2212,9 +2231,9 @@ threadLazyBlackHole(StgTSO *tso)
* above optimisation doesn't apply.
*/
if (bh->header.info != &BLACKHOLE_info
+ && bh->header.info != &BLACKHOLE_BQ_info
&& bh->header.info != &CAF_BLACKHOLE_info) {
SET_INFO(bh,&BLACKHOLE_info);
- bh->blocking_queue = END_TSO_QUEUE;
}
update_frame = update_frame->link;
@@ -2332,13 +2351,9 @@ threadSqueezeStack(StgTSO *tso)
* slower --SDM
*/
#if 0 /* do it properly... */
- if (GET_INFO(updatee_bypass) == BLACKHOLE_info
- || GET_INFO(updatee_bypass) == CAF_BLACKHOLE_info
- ) {
+ if (GET_INFO(updatee_bypass) == BLACKHOLE_BQ_info) {
/* Sigh. It has one. Don't lose those threads! */
- if (GET_INFO(updatee_keep) == BLACKHOLE_info
- || GET_INFO(updatee_keep) == CAF_BLACKHOLE_info
- ) {
+ if (GET_INFO(updatee_keep) == BLACKHOLE_BQ_info) {
/* Urgh. Two queues. Merge them. */
P_ keep_tso = ((StgBlackHole *)updatee_keep)->blocking_queue;
@@ -2375,10 +2390,10 @@ threadSqueezeStack(StgTSO *tso)
if (is_update_frame) {
StgBlackHole *bh = (StgBlackHole *)frame->updatee;
if (bh->header.info != &BLACKHOLE_info
+ && bh->header.info != &BLACKHOLE_BQ_info
&& bh->header.info != &CAF_BLACKHOLE_info
) {
SET_INFO(bh,&BLACKHOLE_info);
- bh->blocking_queue = END_TSO_QUEUE;
}
}
diff --git a/ghc/rts/Printer.c b/ghc/rts/Printer.c
index 74a8c3ce703ebeca9bae6a367ae4282fd199af30..e22e6ed9f091f0e8839b0235aedbf198634458a9 100644
--- a/ghc/rts/Printer.c
+++ b/ghc/rts/Printer.c
@@ -1,6 +1,6 @@
/* -*- mode: hugs-c; -*- */
/* -----------------------------------------------------------------------------
- * $Id: Printer.c,v 1.2 1998/12/02 13:28:33 simonm Exp $
+ * $Id: Printer.c,v 1.3 1999/01/15 17:57:09 simonm Exp $
*
* Copyright (c) 1994-1998.
*
@@ -145,7 +145,10 @@ void printClosure( StgClosure *obj )
fprintf(stderr,")\n");
break;
case BLACKHOLE:
- fprintf(stderr,"BH(");
+ fprintf(stderr,"BH\n");
+ break;
+ case BLACKHOLE_BQ:
+ fprintf(stderr,"BQ(");
printPtr((StgPtr)stgCast(StgBlackHole*,obj)->blocking_queue);
fprintf(stderr,")\n");
break;
diff --git a/ghc/rts/Sanity.c b/ghc/rts/Sanity.c
index 874533a086178cca08c2519c3bd71754647a3792..1ba464d1c291d64f012bea272bfa238899d2d62d 100644
--- a/ghc/rts/Sanity.c
+++ b/ghc/rts/Sanity.c
@@ -1,5 +1,5 @@
/* -----------------------------------------------------------------------------
- * $Id: Sanity.c,v 1.3 1999/01/13 17:25:43 simonm Exp $
+ * $Id: Sanity.c,v 1.4 1999/01/15 17:57:10 simonm Exp $
*
* Sanity checking code for the heap and stack.
*
@@ -203,6 +203,7 @@ checkClosure( StgClosure* p )
case CAF_ENTERED:
case CAF_BLACKHOLE:
case BLACKHOLE:
+ case BLACKHOLE_BQ:
case FOREIGN:
case MVAR:
case MUT_VAR:
diff --git a/ghc/rts/StgMiscClosures.hc b/ghc/rts/StgMiscClosures.hc
index f426d598ad3545674f27e4942e6049421ce8bf1e..1edc735fb7d644821dd930467572e29990f01c4e 100644
--- a/ghc/rts/StgMiscClosures.hc
+++ b/ghc/rts/StgMiscClosures.hc
@@ -1,5 +1,5 @@
/* -----------------------------------------------------------------------------
- * $Id: StgMiscClosures.hc,v 1.4 1999/01/15 12:47:20 sewardj Exp $
+ * $Id: StgMiscClosures.hc,v 1.5 1999/01/15 17:57:11 simonm Exp $
*
* Entry code for various built-in closure types.
*
@@ -132,8 +132,23 @@ STGFUN(CAF_ENTERED_entry)
* should be big enough for an old-generation indirection.
*/
-INFO_TABLE(BLACKHOLE_info, BLACKHOLE_entry,1,1,BLACKHOLE,const,EF_,0,0);
+INFO_TABLE(BLACKHOLE_info, BLACKHOLE_entry,0,2,BLACKHOLE,const,EF_,0,0);
STGFUN(BLACKHOLE_entry)
+{
+ FB_
+ /* Change the BLACKHOLE into a BLACKHOLE_BQ */
+ ((StgBlackHole *)R1.p)->header.info = &BLACKHOLE_BQ_info;
+ /* Put ourselves on the blocking queue for this black hole */
+ CurrentTSO->link = (StgTSO *)&END_TSO_QUEUE_closure;
+ ((StgBlackHole *)R1.p)->blocking_queue = CurrentTSO;
+
+ /* stg_gen_block is too heavyweight, use a specialised one */
+ BLOCK_NP(1);
+ FE_
+}
+
+INFO_TABLE(BLACKHOLE_BQ_info, BLACKHOLE_BQ_entry,1,1,BLACKHOLE_BQ,const,EF_,0,0);
+STGFUN(BLACKHOLE_BQ_entry)
{
FB_
/* Put ourselves on the blocking queue for this black hole */
@@ -146,12 +161,14 @@ STGFUN(BLACKHOLE_entry)
}
/* identical to BLACKHOLEs except for the infotag */
-INFO_TABLE(CAF_BLACKHOLE_info, CAF_BLACKHOLE_entry,1,1,CAF_BLACKHOLE,const,EF_,0,0);
+INFO_TABLE(CAF_BLACKHOLE_info, CAF_BLACKHOLE_entry,0,2,CAF_BLACKHOLE,const,EF_,0,0);
STGFUN(CAF_BLACKHOLE_entry)
{
FB_
+ /* Change the BLACKHOLE into a BLACKHOLE_BQ */
+ ((StgBlackHole *)R1.p)->header.info = &BLACKHOLE_BQ_info;
/* Put ourselves on the blocking queue for this black hole */
- CurrentTSO->link = ((StgBlackHole *)R1.p)->blocking_queue;
+ CurrentTSO->link = (StgTSO *)&END_TSO_QUEUE_closure;
((StgBlackHole *)R1.p)->blocking_queue = CurrentTSO;
/* stg_gen_block is too heavyweight, use a specialised one */
diff --git a/ghc/rts/Updates.hc b/ghc/rts/Updates.hc
index a74e805a5262b83b24f8252da4445fa34c7a1cb1..c98dfa1f660402857af1c568c3f4074a44e1792e 100644
--- a/ghc/rts/Updates.hc
+++ b/ghc/rts/Updates.hc
@@ -1,5 +1,5 @@
/* -----------------------------------------------------------------------------
- * $Id: Updates.hc,v 1.5 1999/01/14 14:43:46 simonm Exp $
+ * $Id: Updates.hc,v 1.6 1999/01/15 17:57:11 simonm Exp $
*
* Code to perform updates.
*
@@ -305,10 +305,10 @@ EXTFUN(stg_update_PAP)
case SEQ_FRAME:
/* Set Sp to just above the SEQ frame (should be an activation rec.)*/
- Sp = stgCast(StgPtr,Su) + sizeofW(StgSeqFrame);
+ Sp = (P_)Su + sizeofW(StgSeqFrame);
/* restore Su */
- Su = stgCast(StgSeqFrame*,Su)->link;
+ Su = ((StgSeqFrame *)Su)->link;
/* return to the activation record, with the address of the PAP in R1 */
R1.p = (P_)PapClosure;
@@ -316,10 +316,10 @@ EXTFUN(stg_update_PAP)
case CATCH_FRAME:
/* Set Sp to just above the CATCH frame (should be an activation rec.)*/
- Sp = stgCast(StgPtr,Su) + sizeofW(StgCatchFrame);
+ Sp = (P_)Su + sizeofW(StgCatchFrame);
/* restore Su */
- Su = stgCast(StgCatchFrame*,Su)->link;
+ Su = ((StgCatchFrame *)Su)->link;
/* restart by entering the PAP */
R1.p = (P_)PapClosure;
@@ -455,7 +455,7 @@ STGFUN(AP_UPD_entry)
IFN_(label) \
{ \
FB_ \
- Su = stgCast(StgSeqFrame*,Sp)->link; \
+ Su = ((StgSeqFrame *)Sp)->link; \
Sp += sizeofW(StgSeqFrame); \
JMP_(ret); \
FE_ \
@@ -566,11 +566,11 @@ FN_(catchZh_fast)
/* args: R1 = m, R2 = k */
STK_CHK_GEN(sizeofW(StgCatchFrame), R1_PTR | R2_PTR, catchZh_fast, );
Sp -= sizeofW(StgCatchFrame);
- fp = stgCast(StgCatchFrame*,Sp);
+ fp = (StgCatchFrame *)Sp;
SET_HDR(fp,(StgInfoTable *)&catch_frame_info,CCCS);
fp -> handler = R2.cl;
fp -> link = Su;
- Su = stgCast(StgUpdateFrame*,fp);
+ Su = (StgUpdateFrame *)fp;
TICK_ENT_VIA_NODE();
JMP_(ENTRY_CODE(*R1.p));
@@ -591,7 +591,7 @@ INFO_TABLE(raise_info,raise_entry,1,0,FUN,const,EF_,0,0);
STGFUN(raise_entry)
{
FB_
- R1.cl = payloadCPtr(R1.cl,0);
+ R1.cl = R1.cl->payload[0];
JMP_(raiseZh_fast);
FE_
}
@@ -600,22 +600,32 @@ FN_(raiseZh_fast)
{
StgClosure *handler;
StgUpdateFrame *p;
+ StgClosure *raise_closure;
FB_
/* args : R1 = error */
p = Su;
+ /* This closure represents the expression 'raise# E' where E
+ * is the exception raise. It is used to overwrite all the
+ * thunks which are currently under evaluataion.
+ */
+ raise_closure = (StgClosure *)RET_STGCALL1(P_,allocate,
+ sizeofW(StgClosure)+1);
+ raise_closure->header.info = &raise_info;
+ raise_closure->payload[0] = R1.cl;
+
while (1) {
switch (get_itbl(p)->type) {
case UPDATE_FRAME:
- UPD_INPLACE1(p->updatee,&raise_info,R1.cl);
+ UPD_IND(p->updatee,raise_closure);
p = p->link;
continue;
case SEQ_FRAME:
- p = stgCast(StgSeqFrame*,p)->link;
+ p = ((StgSeqFrame *)p)->link;
continue;
case CATCH_FRAME:
@@ -639,7 +649,7 @@ FN_(raiseZh_fast)
Su = ((StgCatchFrame *)p)->link;
handler = ((StgCatchFrame *)p)->handler;
- Sp = stgCast(StgPtr,p) + sizeofW(StgCatchFrame) - 1;
+ Sp = (P_)p + sizeofW(StgCatchFrame) - 1;
*Sp = R1.w;
TICK_ENT_VIA_NODE();