/* -----------------------------------------------------------------------------
- * $Id: StgMiscClosures.hc,v 1.26 1999/07/06 16:40:27 sewardj Exp $
+ * $Id: StgMiscClosures.hc,v 1.30 1999/11/30 11:43:26 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
#include "Storage.h"
#include "StoragePriv.h"
#include "ProfRts.h"
+#include "SMP.h"
#ifdef HAVE_STDIO_H
#include <stdio.h>
/* 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.
waiting for the evaluation of the closure to finish.
-------------------------------------------------------------------------- */
-/* Note: a black hole must be big enough to be overwritten with an
- * indirection/evacuee/catch. Thus we claim it has 1 non-pointer word of
- * payload (in addition to the pointer word for the blocking queue), which
- * should be big enough for an old-generation indirection.
+/* Note: a BLACKHOLE and BLACKHOLE_BQ must be big enough to be
+ * overwritten with an indirection/evacuee/catch. Thus we claim it
+ * has 1 non-pointer word of payload (in addition to the pointer word
+ * for the blocking queue in a BQ), which should be big enough for an
+ * old-generation indirection.
*/
INFO_TABLE(BLACKHOLE_info, BLACKHOLE_entry,0,2,BLACKHOLE,,EF_,0,0);
STGFUN(BLACKHOLE_entry)
{
FB_
+#ifdef SMP
+ CMPXCHG(R1.cl->header.info, &BLACKHOLE_info, &WHITEHOLE_info);
+#endif
+
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;
+ CurrentTSO->why_blocked = BlockedOnBlackHole;
+ CurrentTSO->block_info.closure = R1.cl;
recordMutable((StgMutClosure *)R1.cl);
-
+ /* Change the BLACKHOLE into a BLACKHOLE_BQ */
+ ((StgBlockingQueue *)R1.p)->header.info = &BLACKHOLE_BQ_info;
/* stg_gen_block is too heavyweight, use a specialised one */
BLOCK_NP(1);
FE_
STGFUN(BLACKHOLE_BQ_entry)
{
FB_
+#ifdef SMP
+ CMPXCHG(R1.cl->header.info, &BLACKHOLE_BQ_info, &WHITEHOLE_info);
+#endif
+
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;
+#ifdef SMP
+ ((StgBlockingQueue *)R1.p)->header.info = &BLACKHOLE_BQ_info;
+#endif
/* stg_gen_block is too heavyweight, use a specialised one */
BLOCK_NP(1);
STGFUN(CAF_BLACKHOLE_entry)
{
FB_
+#ifdef SMP
+ CMPXCHG(R1.cl->header.info, &CAF_BLACKHOLE_info, &WHITEHOLE_info);
+
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;
+ CurrentTSO->why_blocked = BlockedOnBlackHole;
+ CurrentTSO->block_info.closure = R1.cl;
recordMutable((StgMutClosure *)R1.cl);
-
+ /* Change the CAF_BLACKHOLE into a BLACKHOLE_BQ */
+ ((StgBlockingQueue *)R1.p)->header.info = &BLACKHOLE_BQ_info;
/* stg_gen_block is too heavyweight, use a specialised one */
BLOCK_NP(1);
+
+#else
+ JMP_(BLACKHOLE_entry);
+#endif
+
FE_
}
STGFUN(SE_BLACKHOLE_entry)
{
FB_
- STGCALL1(fflush,stdout);
STGCALL3(fprintf,stderr,"SE_BLACKHOLE at %p entered!\n",R1.p);
- STGCALL1(raiseError, errorHandler);
- stg_exit(EXIT_FAILURE); /* not executed */
+ STGCALL1(shutdownHaskellAndExit,EXIT_FAILURE);
FE_
}
STGFUN(SE_CAF_BLACKHOLE_entry)
{
FB_
- STGCALL1(fflush,stdout);
STGCALL3(fprintf,stderr,"SE_CAF_BLACKHOLE at %p entered!\n",R1.p);
- STGCALL1(raiseError, errorHandler);
- stg_exit(EXIT_FAILURE); /* not executed */
+ STGCALL1(shutdownHaskellAndExit,EXIT_FAILURE);
+ FE_
+}
+#endif
+
+#ifdef SMP
+INFO_TABLE(WHITEHOLE_info, WHITEHOLE_entry,0,2,CONSTR_NOCAF_STATIC,,EF_,0,0);
+STGFUN(WHITEHOLE_entry)
+{
+ FB_
+ JMP_(GET_ENTRY(R1.cl));
FE_
}
#endif
{ \
FB_ \
DUMP_ERRMSG(#type " object entered!\n"); \
- STGCALL1(raiseError, errorHandler); \
- stg_exit(EXIT_FAILURE); /* not executed */ \
+ STGCALL1(shutdownHaskellAndExit, EXIT_FAILURE); \
FE_ \
}
NON_ENTERABLE_ENTRY_CODE(NO_FINALIZER);
SET_STATIC_HDR(NO_FINALIZER_closure,NO_FINALIZER_info,0/*CC*/,,EI_)
-};
+, /*payload*/{} };
/* -----------------------------------------------------------------------------
Foreign Objects are unlifted and therefore never entered.
NON_ENTERABLE_ENTRY_CODE(END_TSO_QUEUE);
SET_STATIC_HDR(END_TSO_QUEUE_closure,END_TSO_QUEUE_info,0/*CC*/,,EI_)
-};
+, /*payload*/{} };
/* -----------------------------------------------------------------------------
Mutable lists
NON_ENTERABLE_ENTRY_CODE(END_MUT_LIST);
SET_STATIC_HDR(END_MUT_LIST_closure,END_MUT_LIST_info,0/*CC*/,,EI_)
-};
+, /*payload*/{} };
INFO_TABLE(MUT_CONS_info, MUT_CONS_entry, 1, 1, MUT_VAR, , EF_, 0, 0);
NON_ENTERABLE_ENTRY_CODE(MUT_CONS);
/* -----------------------------------------------------------------------------
+ Exception lists
+ -------------------------------------------------------------------------- */
+
+INFO_TABLE_CONSTR(END_EXCEPTION_LIST_info,END_EXCEPTION_LIST_entry,0,0,0,CONSTR_NOCAF_STATIC,,EF_,0,0);
+NON_ENTERABLE_ENTRY_CODE(END_EXCEPTION_LIST);
+
+SET_STATIC_HDR(END_EXCEPTION_LIST_closure,END_EXCEPTION_LIST_info,0/*CC*/,,EI_)
+, /*payload*/{} };
+
+INFO_TABLE(EXCEPTION_CONS_info, EXCEPTION_CONS_entry, 1, 1, CONSTR, , EF_, 0, 0);
+NON_ENTERABLE_ENTRY_CODE(EXCEPTION_CONS);
+
+/* -----------------------------------------------------------------------------
Arrays
These come in two basic flavours: arrays of data (StgArrWords) and arrays of
{ \
FB_ \
DUMP_ERRMSG("fatal: stg_error_entry"); \
- STGCALL1(raiseError, errorHandler); \
- exit(EXIT_FAILURE); /* not executed */ \
+ STGCALL1(shutdownHaskellAndExit, EXIT_FAILURE); \
FE_ \
}
FE_
}
SET_STATIC_HDR(dummy_ret_closure,dummy_ret_info,CCS_DONTZuCARE,,EI_)
-};
+, /*payload*/{} };
/* -----------------------------------------------------------------------------
Strict IO application - performing an IO action and entering its result.
FE_
}
SET_STATIC_HDR(forceIO_closure,forceIO_info,CCS_DONTZuCARE,,EI_)
-};
+, /*payload*/{} };
/* -----------------------------------------------------------------------------
projects / ghc-hetmet.git / blobdiff