/* ----------------------------------------------------------------------------
- * $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
*
#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
/* ----------------------------------------------------------------------------
- * $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
*
, SEQ_FRAME
, BLACKHOLE
+ , BLACKHOLE_BQ
+
, MVAR
, ARR_WORDS
-
, MUT_ARR_WORDS
+
, MUT_ARR_PTRS
, MUT_ARR_PTRS_FROZEN
+
, MUT_VAR
, WEAK
#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 )
/* -----------------------------------------------------------------------------
- * $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.
*
STGFUN(CAF_ENTERED_entry);
STGFUN(CAF_BLACKHOLE_entry);
STGFUN(BLACKHOLE_entry);
+STGFUN(BLACKHOLE_BQ_entry);
STGFUN(BCO_entry);
STGFUN(EVACUATED_entry);
STGFUN(FOREIGN_entry);
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;
/* -----------------------------------------------------------------------------
- * $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.
*
(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
-------------------------------------------------------------------------- */
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); \
{ \
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); \
}
/* -----------------------------------------------------------------------------
- * $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
*
, "SEQ_FRAME"
, "BLACKHOLE"
+ , "BLACKHOLE_BQ"
, "MVAR"
, "ARR_WORDS"
case IND_PERM:
case IND_OLDGEN_PERM:
case BLACKHOLE:
+ case BLACKHOLE_BQ:
case WEAK:
case FOREIGN:
case MVAR:
* 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"
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;
/* -----------------------------------------------------------------------------
- * $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
*
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;
case CAF_UNENTERED:
case CAF_BLACKHOLE:
case BLACKHOLE:
+ case BLACKHOLE_BQ:
/* not evaluated yet */
break;
case CAF_BLACKHOLE:
case BLACKHOLE:
+ p += BLACKHOLE_sizeW();
+ break;
+
+ case BLACKHOLE_BQ:
{
StgBlackHole *bh = (StgBlackHole *)p;
(StgClosure *)bh->blocking_queue =
case CAF_BLACKHOLE:
case BLACKHOLE:
+ break;
+
+ case BLACKHOLE_BQ:
{
StgBlackHole *bh = (StgBlackHole *)p;
(StgClosure *)bh->blocking_queue =
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:
{
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;
* 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;
* 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;
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;
}
}
/* -*- 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.
*
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;
/* -----------------------------------------------------------------------------
- * $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.
*
case CAF_ENTERED:
case CAF_BLACKHOLE:
case BLACKHOLE:
+ case BLACKHOLE_BQ:
case FOREIGN:
case MVAR:
case MUT_VAR:
/* -----------------------------------------------------------------------------
- * $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.
*
* 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 */
CurrentTSO->link = ((StgBlackHole *)R1.p)->blocking_queue;
((StgBlackHole *)R1.p)->blocking_queue = CurrentTSO;
}
/* 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 */
/* -----------------------------------------------------------------------------
- * $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.
*
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;
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;
IFN_(label) \
{ \
FB_ \
- Su = stgCast(StgSeqFrame*,Sp)->link; \
+ Su = ((StgSeqFrame *)Sp)->link; \
Sp += sizeofW(StgSeqFrame); \
JMP_(ret); \
FE_ \
/* 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));
STGFUN(raise_entry)
{
FB_
- R1.cl = payloadCPtr(R1.cl,0);
+ R1.cl = R1.cl->payload[0];
JMP_(raiseZh_fast);
FE_
}
{
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:
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();
projects / ghc-hetmet.git / commitdiff