/* -----------------------------------------------------------------------------
- * $Id: StgMiscClosures.hc,v 1.16 1999/03/09 14:24:45 sewardj Exp $
+ * $Id: StgMiscClosures.hc,v 1.32 2000/01/14 11:45:21 hwloidl Exp $
*
* (c) The GHC Team, 1998-1999
*
#include "Rts.h"
#include "RtsUtils.h"
+#include "RtsFlags.h"
#include "StgMiscClosures.h"
#include "HeapStackCheck.h" /* for stg_gen_yield */
#include "Storage.h"
#include "StoragePriv.h"
+#include "ProfRts.h"
+#include "SMP.h"
+#if defined(GRAN) || defined(PAR)
+# include "GranSimRts.h" /* for DumpRawGranEvent */
+# include "StgRun.h" /* for StgReturn and register saving */
+#endif
#ifdef HAVE_STDIO_H
#include <stdio.h>
#endif
+/* ToDo: make the printing of panics more Win32-friendly, i.e.,
+ * pop up some lovely message boxes (as well).
+ */
+#define DUMP_ERRMSG(msg) STGCALL2(fprintf,stderr,msg)
+
+/*
+ Template for the entry code of non-enterable closures.
+*/
+
+#define NON_ENTERABLE_ENTRY_CODE(type) \
+STGFUN(type##_entry) \
+{ \
+ FB_ \
+ DUMP_ERRMSG(#type " object entered!\n"); \
+ STGCALL1(shutdownHaskellAndExit, EXIT_FAILURE); \
+ FE_ \
+}
+
/* -----------------------------------------------------------------------------
Entry code for an indirection.
This code assumes R1 is in a register for now.
-------------------------------------------------------------------------- */
-INFO_TABLE(IND_info,IND_entry,1,0,IND,const,EF_,0,0);
+INFO_TABLE(IND_info,IND_entry,1,0,IND,,EF_,0,0);
STGFUN(IND_entry)
{
FB_
R1.p = (P_) ((StgInd*)R1.p)->indirectee;
TICK_ENT_VIA_NODE();
- JMP_(*R1.p);
+ JMP_(ENTRY_CODE(*R1.p));
FE_
}
-INFO_TABLE(IND_STATIC_info,IND_STATIC_entry,1,0,IND_STATIC,const,EF_,0,0);
+INFO_TABLE(IND_STATIC_info,IND_STATIC_entry,1,0,IND_STATIC,,EF_,0,0);
STGFUN(IND_STATIC_entry)
{
FB_
R1.p = (P_) ((StgIndStatic*)R1.p)->indirectee;
TICK_ENT_VIA_NODE();
- JMP_(*R1.p);
+ JMP_(ENTRY_CODE(*R1.p));
FE_
}
-INFO_TABLE(IND_PERM_info,IND_PERM_entry,1,0,IND_PERM,const,EF_,0,0);
+INFO_TABLE(IND_PERM_info,IND_PERM_entry,1,1,IND_PERM,,EF_,0,0);
STGFUN(IND_PERM_entry)
{
FB_
/* Don't add INDs to granularity cost */
+ /* Dont: TICK_ENT_IND(Node); for ticky-ticky; this ind is here only to help profiling */
- /* Dont: ENT_IND(Node); for ticky-ticky; this ind is here only to help profi
-ling */
+#if defined(TICKY_TICKY) && !defined(PROFILING)
+ /* TICKY_TICKY && !PROFILING means PERM_IND *replaces* an IND, rather than being extra */
+ TICK_ENT_PERM_IND(R1.p); /* tick */
+#endif
/* Enter PAP cost centre -- lexical scoping only */
ENTER_CCS_PAP_CL(R1.cl);
+ /* For ticky-ticky, change the perm_ind to a normal ind on first
+ * entry, so the number of ent_perm_inds is the number of *thunks*
+ * entered again, not the number of subsequent entries.
+ *
+ * Since this screws up cost centres, we die if profiling and
+ * ticky_ticky are on at the same time. KSW 1999-01.
+ */
+
+#ifdef TICKY_TICKY
+# ifdef PROFILING
+# error Profiling and ticky-ticky do not mix at present!
+# endif /* PROFILING */
+ SET_INFO((StgInd*)R1.p,&IND_info);
+#endif /* TICKY_TICKY */
+
R1.p = (P_) ((StgInd*)R1.p)->indirectee;
/* Dont: TICK_ENT_VIA_NODE(); for ticky-ticky; as above */
- JMP_(*R1.p);
+#if defined(TICKY_TICKY) && !defined(PROFILING)
+ TICK_ENT_VIA_NODE();
+#endif
+
+ JMP_(ENTRY_CODE(*R1.p));
FE_
}
-INFO_TABLE(IND_OLDGEN_info,IND_OLDGEN_entry,1,1,IND_OLDGEN,const,EF_,0,0);
+INFO_TABLE(IND_OLDGEN_info,IND_OLDGEN_entry,1,1,IND_OLDGEN,,EF_,0,0);
STGFUN(IND_OLDGEN_entry)
{
FB_
R1.p = (P_) ((StgInd*)R1.p)->indirectee;
TICK_ENT_VIA_NODE();
- JMP_(*R1.p);
+ JMP_(ENTRY_CODE(*R1.p));
FE_
}
-INFO_TABLE(IND_OLDGEN_PERM_info,IND_OLDGEN_PERM_entry,1,1,IND_OLDGEN_PERM,const,EF_,0,0);
+INFO_TABLE(IND_OLDGEN_PERM_info,IND_OLDGEN_PERM_entry,1,1,IND_OLDGEN_PERM,,EF_,0,0);
STGFUN(IND_OLDGEN_PERM_entry)
{
FB_
- TICK_ENT_IND(Node); /* tick */
+ /* Dont: TICK_ENT_IND(Node); for ticky-ticky; this ind is here only to help profiling */
+
+#if defined(TICKY_TICKY) && !defined(PROFILING)
+ /* TICKY_TICKY && !PROFILING means PERM_IND *replaces* an IND, rather than being extra */
+ TICK_ENT_PERM_IND(R1.p); /* tick */
+#endif
+ /* Enter PAP cost centre -- lexical scoping only */
+ ENTER_CCS_PAP_CL(R1.cl);
+
+ /* see comment in IND_PERM */
+#ifdef TICKY_TICKY
+# ifdef PROFILING
+# error Profiling and ticky-ticky do not mix at present!
+# endif /* PROFILING */
+ SET_INFO((StgInd*)R1.p,&IND_OLDGEN_info);
+#endif /* TICKY_TICKY */
+
R1.p = (P_) ((StgInd*)R1.p)->indirectee;
TICK_ENT_VIA_NODE();
- JMP_(*R1.p);
+ JMP_(ENTRY_CODE(*R1.p));
FE_
}
This code assumes R1 is in a register for now.
-------------------------------------------------------------------------- */
-INFO_TABLE(CAF_UNENTERED_info,CAF_UNENTERED_entry,1,3,CAF_UNENTERED,const,EF_,0,0);
+INFO_TABLE(CAF_UNENTERED_info,CAF_UNENTERED_entry,1,3,CAF_UNENTERED,,EF_,0,0);
STGFUN(CAF_UNENTERED_entry)
{
FB_
}
/* 0,4 is entirely bogus; _do not_ rely on this info */
-INFO_TABLE(CAF_ENTERED_info,CAF_ENTERED_entry,0,4,CAF_ENTERED,const,EF_,0,0);
+INFO_TABLE(CAF_ENTERED_info,CAF_ENTERED_entry,0,4,CAF_ENTERED,,EF_,0,0);
STGFUN(CAF_ENTERED_entry)
{
FB_
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,const,EF_,0,0);
+INFO_TABLE(BLACKHOLE_info, BLACKHOLE_entry,0,2,BLACKHOLE,,EF_,0,0);
STGFUN(BLACKHOLE_entry)
{
FB_
+#if defined(GRAN)
+ /* Before overwriting TSO_LINK */
+ STGCALL3(GranSimBlock,CurrentTSO,CurrentProc,(StgClosure *)R1.p /*Node*/);
+#endif
+
+#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;
+#if defined(GRAN) || defined(PAR)
+ /* in fact, only difference is the type of the end-of-queue marker! */
+ CurrentTSO->link = END_BQ_QUEUE;
+ ((StgBlockingQueue *)R1.p)->blocking_queue = (StgBlockingQueueElement *)CurrentTSO;
+#else
+ CurrentTSO->link = END_TSO_QUEUE;
((StgBlockingQueue *)R1.p)->blocking_queue = CurrentTSO;
+#endif
+ /* jot down why and on what closure we are blocked */
+ CurrentTSO->why_blocked = BlockedOnBlackHole;
+ CurrentTSO->block_info.closure = R1.cl;
+ /* closure is mutable since something has just been added to its BQ */
recordMutable((StgMutClosure *)R1.cl);
+ /* Change the BLACKHOLE into a BLACKHOLE_BQ */
+ ((StgBlockingQueue *)R1.p)->header.info = &BLACKHOLE_BQ_info;
+#if defined(PAR)
+ /* Save the Thread State here, before calling RTS routines below! */
+ SAVE_THREAD_STATE(1);
+
+ /* if collecting stats update the execution time etc */
+ if (RtsFlags.ParFlags.ParStats.Full) {
+ /* Note that CURRENT_TIME may perform an unsafe call */
+ //rtsTime now = CURRENT_TIME; /* Now */
+ CurrentTSO->par.exectime += CURRENT_TIME - CurrentTSO->par.blockedat;
+ CurrentTSO->par.blockcount++;
+ CurrentTSO->par.blockedat = CURRENT_TIME;
+ DumpRawGranEvent(CURRENT_PROC, thisPE,
+ GR_BLOCK, CurrentTSO, (StgClosure *)R1.p, 0);
+ }
+
+ THREAD_RETURN(1); /* back to the scheduler */
+#else
/* stg_gen_block is too heavyweight, use a specialised one */
BLOCK_NP(1);
+#endif
+
FE_
}
-INFO_TABLE(BLACKHOLE_BQ_info, BLACKHOLE_BQ_entry,1,1,BLACKHOLE_BQ,const,EF_,0,0);
+INFO_TABLE(BLACKHOLE_BQ_info, BLACKHOLE_BQ_entry,1,1,BLACKHOLE_BQ,,EF_,0,0);
STGFUN(BLACKHOLE_BQ_entry)
{
FB_
+#if defined(GRAN)
+ /* Before overwriting TSO_LINK */
+ STGCALL3(GranSimBlock,CurrentTSO,CurrentProc,(StgClosure *)R1.p /*Node*/);
+#endif
+
+#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->link = ((StgBlockingQueue *)R1.p)->blocking_queue;
((StgBlockingQueue *)R1.p)->blocking_queue = CurrentTSO;
+ /* jot down why and on what closure we are blocked */
+ CurrentTSO->why_blocked = BlockedOnBlackHole;
+ CurrentTSO->block_info.closure = R1.cl;
+#ifdef SMP
+ ((StgBlockingQueue *)R1.p)->header.info = &BLACKHOLE_BQ_info;
+#endif
+#if defined(PAR)
+ /* Save the Thread State here, before calling RTS routines below! */
+ SAVE_THREAD_STATE(1);
+
+ /* if collecting stats update the execution time etc */
+ if (RtsFlags.ParFlags.ParStats.Full) {
+ /* Note that CURRENT_TIME may perform an unsafe call */
+ //rtsTime now = CURRENT_TIME; /* Now */
+ CurrentTSO->par.exectime += CURRENT_TIME - CurrentTSO->par.blockedat;
+ CurrentTSO->par.blockcount++;
+ CurrentTSO->par.blockedat = CURRENT_TIME;
+ DumpRawGranEvent(CURRENT_PROC, thisPE,
+ GR_BLOCK, CurrentTSO, (StgClosure *)R1.p, 0);
+ }
+
+ THREAD_RETURN(1); /* back to the scheduler */
+#else
/* stg_gen_block is too heavyweight, use a specialised one */
BLOCK_NP(1);
+#endif
+ FE_
+}
+
+/*
+ Revertible black holes are needed in the parallel world, to handle
+ negative acknowledgements of messages containing updatable closures.
+ The idea is that when the original message is transmitted, the closure
+ is turned into a revertible black hole...an object which acts like a
+ black hole when local threads try to enter it, but which can be reverted
+ back to the original closure if necessary.
+
+ It's actually a lot like a blocking queue (BQ) entry, because revertible
+ black holes are initially set up with an empty blocking queue.
+*/
+
+#if defined(PAR) || defined(GRAN)
+
+INFO_TABLE(RBH_info, RBH_entry,1,1,RBH,,EF_,0,0);
+STGFUN(RBH_entry)
+{
+ FB_
+# if defined(GRAN)
+ /* mainly statistics gathering for GranSim simulation */
+ STGCALL3(GranSimBlock,CurrentTSO,CurrentProc,(StgClosure *)R1.p /*Node*/);
+# endif
+
+ /* exactly the same as a BLACKHOLE_BQ_entry -- HWL */
+ /* Put ourselves on the blocking queue for this black hole */
+ CurrentTSO->link = ((StgBlockingQueue *)R1.p)->blocking_queue;
+ ((StgBlockingQueue *)R1.p)->blocking_queue = CurrentTSO;
+ /* jot down why and on what closure we are blocked */
+ CurrentTSO->why_blocked = BlockedOnBlackHole;
+ CurrentTSO->block_info.closure = R1.cl;
+
+#if defined(PAR)
+ /* Save the Thread State here, before calling RTS routines below! */
+ SAVE_THREAD_STATE(1);
+
+ /* if collecting stats update the execution time etc */
+ if (RtsFlags.ParFlags.ParStats.Full) {
+ /* Note that CURRENT_TIME may perform an unsafe call */
+ //rtsTime now = CURRENT_TIME; /* Now */
+ CurrentTSO->par.exectime += CURRENT_TIME - CurrentTSO->par.blockedat;
+ CurrentTSO->par.blockcount++;
+ CurrentTSO->par.blockedat = CURRENT_TIME;
+ DumpRawGranEvent(CURRENT_PROC, thisPE,
+ GR_BLOCK, CurrentTSO, (StgClosure *)R1.p, 0);
+ }
+
+ THREAD_RETURN(1); /* back to the scheduler */
+#else
+ /* saves thread state and leaves thread in ThreadEnterGHC state; */
+ /* stg_gen_block is too heavyweight, use a specialised one */
+ BLOCK_NP(1);
+#endif
+
FE_
}
+INFO_TABLE(RBH_Save_0_info, RBH_Save_0_entry,0,2,CONSTR,,EF_,0,0);
+NON_ENTERABLE_ENTRY_CODE(RBH_Save_0);
+
+INFO_TABLE(RBH_Save_1_info, RBH_Save_1_entry,1,1,CONSTR,,EF_,0,0);
+NON_ENTERABLE_ENTRY_CODE(RBH_Save_1);
+
+INFO_TABLE(RBH_Save_2_info, RBH_Save_2_entry,2,0,CONSTR,,EF_,0,0);
+NON_ENTERABLE_ENTRY_CODE(RBH_Save_2);
+#endif /* defined(PAR) || defined(GRAN) */
+
/* identical to BLACKHOLEs except for the infotag */
-INFO_TABLE(CAF_BLACKHOLE_info, CAF_BLACKHOLE_entry,0,2,CAF_BLACKHOLE,const,EF_,0,0);
+INFO_TABLE(CAF_BLACKHOLE_info, CAF_BLACKHOLE_entry,0,2,CAF_BLACKHOLE,,EF_,0,0);
STGFUN(CAF_BLACKHOLE_entry)
{
FB_
+#if defined(GRAN)
+ /* mainly statistics gathering for GranSim simulation */
+ STGCALL3(GranSimBlock,CurrentTSO,CurrentProc,(StgClosure *)R1.p /*Node*/);
+#endif
+
+#ifdef SMP
+ CMPXCHG(R1.cl->header.info, &CAF_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;
+#if defined(GRAN) || defined(PAR)
+ /* in fact, only difference is the type of the end-of-queue marker! */
+ CurrentTSO->link = END_BQ_QUEUE;
+ ((StgBlockingQueue *)R1.p)->blocking_queue = (StgBlockingQueueElement *)CurrentTSO;
+#else
+ CurrentTSO->link = END_TSO_QUEUE;
((StgBlockingQueue *)R1.p)->blocking_queue = CurrentTSO;
+#endif
+ /* jot down why and on what closure we are blocked */
+ CurrentTSO->why_blocked = BlockedOnBlackHole;
+ CurrentTSO->block_info.closure = R1.cl;
+ /* closure is mutable since something has just been added to its BQ */
recordMutable((StgMutClosure *)R1.cl);
+ /* Change the CAF_BLACKHOLE into a BLACKHOLE_BQ */
+ ((StgBlockingQueue *)R1.p)->header.info = &BLACKHOLE_BQ_info;
+#if defined(PAR)
+ /* Save the Thread State here, before calling RTS routines below! */
+ SAVE_THREAD_STATE(1);
+
+ /* if collecting stats update the execution time etc */
+ if (RtsFlags.ParFlags.ParStats.Full) {
+ /* Note that CURRENT_TIME may perform an unsafe call */
+ //rtsTime now = CURRENT_TIME; /* Now */
+ CurrentTSO->par.exectime += CURRENT_TIME - CurrentTSO->par.blockedat;
+ CurrentTSO->par.blockcount++;
+ CurrentTSO->par.blockedat = CURRENT_TIME;
+ DumpRawGranEvent(CURRENT_PROC, thisPE,
+ GR_BLOCK, CurrentTSO, (StgClosure *)R1.p, 0);
+ }
+
+ THREAD_RETURN(1); /* back to the scheduler */
+#else
/* stg_gen_block is too heavyweight, use a specialised one */
BLOCK_NP(1);
+#endif
+
+ FE_
+}
+
+#ifdef TICKY_TICKY
+INFO_TABLE(SE_BLACKHOLE_info, SE_BLACKHOLE_entry,0,2,SE_BLACKHOLE,,EF_,0,0);
+STGFUN(SE_BLACKHOLE_entry)
+{
+ FB_
+ STGCALL3(fprintf,stderr,"SE_BLACKHOLE at %p entered!\n",R1.p);
+ STGCALL1(shutdownHaskellAndExit,EXIT_FAILURE);
+ FE_
+}
+
+INFO_TABLE(SE_CAF_BLACKHOLE_info, SE_CAF_BLACKHOLE_entry,0,2,SE_CAF_BLACKHOLE,,EF_,0,0);
+STGFUN(SE_CAF_BLACKHOLE_entry)
+{
+ FB_
+ STGCALL3(fprintf,stderr,"SE_CAF_BLACKHOLE at %p entered!\n",R1.p);
+ 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
/* -----------------------------------------------------------------------------
The code for a BCO returns to the scheduler
-------------------------------------------------------------------------- */
-INFO_TABLE(BCO_info,BCO_entry,0,0,BCO,const,EF_,0,0);
+INFO_TABLE(BCO_info,BCO_entry,0,0,BCO,,EF_,0,0);
EF_(BCO_entry) {
FB_
Sp -= 1;
/* -----------------------------------------------------------------------------
Some static info tables for things that don't get entered, and
therefore don't need entry code (i.e. boxed but unpointed objects)
+ NON_ENTERABLE_ENTRY_CODE now defined at the beginning of the file
-------------------------------------------------------------------------- */
-#define NON_ENTERABLE_ENTRY_CODE(type) \
-STGFUN(type##_entry) \
-{ \
- FB_ \
- STGCALL1(fflush,stdout); \
- STGCALL2(fprintf,stderr,#type " object entered!\n"); \
- STGCALL1(raiseError, errorHandler); \
- stg_exit(EXIT_FAILURE); /* not executed */ \
- FE_ \
-}
-
-INFO_TABLE(TSO_info, TSO_entry, 0,0,TSO,const,EF_,0,0);
+INFO_TABLE(TSO_info, TSO_entry, 0,0,TSO,,EF_,0,0);
NON_ENTERABLE_ENTRY_CODE(TSO);
/* -----------------------------------------------------------------------------
one is a real bug.
-------------------------------------------------------------------------- */
-INFO_TABLE(EVACUATED_info,EVACUATED_entry,1,0,EVACUATED,const,EF_,0,0);
+INFO_TABLE(EVACUATED_info,EVACUATED_entry,1,0,EVACUATED,,EF_,0,0);
NON_ENTERABLE_ENTRY_CODE(EVACUATED);
/* -----------------------------------------------------------------------------
live weak pointers with dead ones).
-------------------------------------------------------------------------- */
-INFO_TABLE(WEAK_info,WEAK_entry,0,4,WEAK,const,EF_,0,0);
+INFO_TABLE(WEAK_info,WEAK_entry,0,4,WEAK,,EF_,0,0);
NON_ENTERABLE_ENTRY_CODE(WEAK);
-INFO_TABLE_CONSTR(DEAD_WEAK_info,DEAD_WEAK_entry,0,1,0,CONSTR,const,EF_,0,0);
+INFO_TABLE_CONSTR(DEAD_WEAK_info,DEAD_WEAK_entry,0,1,0,CONSTR,,EF_,0,0);
NON_ENTERABLE_ENTRY_CODE(DEAD_WEAK);
/* -----------------------------------------------------------------------------
finalizer in a weak pointer object.
-------------------------------------------------------------------------- */
-INFO_TABLE_CONSTR(NO_FINALIZER_info,NO_FINALIZER_entry,0,0,0,CONSTR_NOCAF_STATIC,const,EF_,0,0);
+INFO_TABLE_CONSTR(NO_FINALIZER_info,NO_FINALIZER_entry,0,0,0,CONSTR_NOCAF_STATIC,,EF_,0,0);
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.
-------------------------------------------------------------------------- */
-INFO_TABLE(FOREIGN_info,FOREIGN_entry,0,1,FOREIGN,const,EF_,0,0);
+INFO_TABLE(FOREIGN_info,FOREIGN_entry,0,1,FOREIGN,,EF_,0,0);
NON_ENTERABLE_ENTRY_CODE(FOREIGN);
/* -----------------------------------------------------------------------------
Stable Names are unlifted too.
-------------------------------------------------------------------------- */
-INFO_TABLE(STABLE_NAME_info,STABLE_NAME_entry,0,1,STABLE_NAME,const,EF_,0,0);
+INFO_TABLE(STABLE_NAME_info,STABLE_NAME_entry,0,1,STABLE_NAME,,EF_,0,0);
NON_ENTERABLE_ENTRY_CODE(STABLE_NAME);
/* -----------------------------------------------------------------------------
and entry code for each type.
-------------------------------------------------------------------------- */
-INFO_TABLE(FULL_MVAR_info,FULL_MVAR_entry,4,0,MVAR,const,EF_,0,0);
+INFO_TABLE(FULL_MVAR_info,FULL_MVAR_entry,4,0,MVAR,,EF_,0,0);
NON_ENTERABLE_ENTRY_CODE(FULL_MVAR);
-INFO_TABLE(EMPTY_MVAR_info,EMPTY_MVAR_entry,4,0,MVAR,const,EF_,0,0);
+INFO_TABLE(EMPTY_MVAR_info,EMPTY_MVAR_entry,4,0,MVAR,,EF_,0,0);
NON_ENTERABLE_ENTRY_CODE(EMPTY_MVAR);
/* -----------------------------------------------------------------------------
end of a linked TSO queue.
-------------------------------------------------------------------------- */
-INFO_TABLE_CONSTR(END_TSO_QUEUE_info,END_TSO_QUEUE_entry,0,0,0,CONSTR_NOCAF_STATIC,const,EF_,0,0);
+INFO_TABLE_CONSTR(END_TSO_QUEUE_info,END_TSO_QUEUE_entry,0,0,0,CONSTR_NOCAF_STATIC,,EF_,0,0);
NON_ENTERABLE_ENTRY_CODE(END_TSO_QUEUE);
SET_STATIC_HDR(END_TSO_QUEUE_closure,END_TSO_QUEUE_info,0/*CC*/,,EI_)
-};
+, /*payload*/{} };
/* -----------------------------------------------------------------------------
Mutable lists
an END_MUT_LIST closure.
-------------------------------------------------------------------------- */
-INFO_TABLE_CONSTR(END_MUT_LIST_info,END_MUT_LIST_entry,0,0,0,CONSTR_NOCAF_STATIC,const,EF_,0,0);
+INFO_TABLE_CONSTR(END_MUT_LIST_info,END_MUT_LIST_entry,0,0,0,CONSTR_NOCAF_STATIC,,EF_,0,0);
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, const, EF_, 0, 0);
+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
-------------------------------------------------------------------------- */
-#define ArrayInfo(type) \
-INFO_TABLE(type##_info, type##_entry, 0, 0, type, const, EF_,0,0); \
-NON_ENTERABLE_ENTRY_CODE(type);
+#define ArrayInfo(type) \
+INFO_TABLE(type##_info, type##_entry, 0, 0, type, , EF_,0,0);
ArrayInfo(ARR_WORDS);
+NON_ENTERABLE_ENTRY_CODE(ARR_WORDS);
ArrayInfo(MUT_ARR_PTRS);
+NON_ENTERABLE_ENTRY_CODE(MUT_ARR_PTRS);
ArrayInfo(MUT_ARR_PTRS_FROZEN);
+NON_ENTERABLE_ENTRY_CODE(MUT_ARR_PTRS_FROZEN);
#undef ArrayInfo
Mutable Variables
-------------------------------------------------------------------------- */
-INFO_TABLE(MUT_VAR_info, MUT_VAR_entry, 1, 1, MUT_VAR, const, EF_, 0, 0);
+INFO_TABLE(MUT_VAR_info, MUT_VAR_entry, 1, 1, MUT_VAR, , EF_, 0, 0);
NON_ENTERABLE_ENTRY_CODE(MUT_VAR);
/* -----------------------------------------------------------------------------
STGFUN(stg_error_entry) \
{ \
FB_ \
- STGCALL1(fflush,stdout); \
- STGCALL2(fprintf,stderr,"fatal: stg_error_entry"); \
- STGCALL1(raiseError, errorHandler); \
- exit(EXIT_FAILURE); /* not executed */ \
+ DUMP_ERRMSG("fatal: stg_error_entry"); \
+ STGCALL1(shutdownHaskellAndExit, EXIT_FAILURE); \
FE_ \
}
just enter the top stack word to start the thread. (see deleteThread)
* -------------------------------------------------------------------------- */
-INFO_TABLE(dummy_ret_info, dummy_ret_entry, 0, 0, CONSTR_NOCAF_STATIC, const, EF_, 0, 0);
+INFO_TABLE(dummy_ret_info, dummy_ret_entry, 0, 0, CONSTR_NOCAF_STATIC, , EF_, 0, 0);
FN_(dummy_ret_entry)
{
W_ ret_addr;
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.
+
+ rts_evalIO() lets you perform Haskell IO actions from outside of Haskell-land,
+ returning back to you their result. Want this result to be evaluated to WHNF
+ by that time, so that we can easily get at the int/char/whatever using the
+ various get{Ty} functions provided by the RTS API.
+
+ forceIO takes care of this, performing the IO action and entering the
+ results that comes back.
+
+ * -------------------------------------------------------------------------- */
+
+INFO_TABLE_SRT_BITMAP(forceIO_ret_info,forceIO_ret_entry,0,0,0,0,RET_SMALL,,EF_,0,0);
+FN_(forceIO_ret_entry)
+{
+ FB_
+ Sp++;
+ Sp -= sizeofW(StgSeqFrame);
+ PUSH_SEQ_FRAME(Sp);
+ JMP_(GET_ENTRY(R1.cl));
+}
+
+
+INFO_TABLE(forceIO_info,forceIO_entry,1,0,FUN,,EF_,0,0);
+FN_(forceIO_entry)
+{
+ FB_
+ /* Sp[0] contains the IO action we want to perform */
+ R1.p = (P_)Sp[0];
+ /* Replace it with the return continuation that enters the result. */
+ Sp[0] = (W_)&forceIO_ret_info;
+ Sp--;
+ /* Push the RealWorld# tag and enter */
+ Sp[0] =(W_)REALWORLD_TAG;
+ JMP_(GET_ENTRY(R1.cl));
+ FE_
+}
+SET_STATIC_HDR(forceIO_closure,forceIO_info,CCS_DONTZuCARE,,EI_)
+, /*payload*/{} };
+
/* -----------------------------------------------------------------------------
Standard Infotables (for use in interpreter)
STGFUN(Hugs_CONSTR_entry)
{
- Sp -= 1;
- ((StgPtr*)Sp)[0] = R1.p;
- /* vectored: JMP_(RET_VEC(((StgPtr*)Sp)[1],constrTag(?))); */
- JMP_(ENTRY_CODE(((StgPtr*)Sp)[1]));
+ /* R1 points at the constructor */
+ JMP_(ENTRY_CODE(((StgPtr*)Sp)[0]));
}
#define RET_BCO_ENTRY_TEMPLATE(label) \
RET_BCO_ENTRY_TEMPLATE(ret_bco_6_entry);
RET_BCO_ENTRY_TEMPLATE(ret_bco_7_entry);
-VEC_POLY_INFO_TABLE(ret_bco,0, NULL/*srt*/, 0/*srt_off*/, 0/*srt_len*/, RET_BCO);
+VEC_POLY_INFO_TABLE(ret_bco,0, NULL/*srt*/, 0/*srt_off*/, 0/*srt_len*/, RET_BCO,, EF_);
#endif /* INTERPRETER */
#ifndef COMPILER
-INFO_TABLE_CONSTR(Czh_con_info,Hugs_CONSTR_entry,0,sizeofW(StgChar),0,CONSTR,const,EF_,0,0);
-INFO_TABLE_CONSTR(Izh_con_info,Hugs_CONSTR_entry,0,sizeofW(StgInt),0,CONSTR,const,EF_,0,0);
-INFO_TABLE_CONSTR(I64zh_con_info,Hugs_CONSTR_entry,0,sizeofW(StgInt64),0,CONSTR,const,EF_,0,0);
-INFO_TABLE_CONSTR(Fzh_con_info,Hugs_CONSTR_entry,0,sizeofW(StgFloat),0,CONSTR,const,EF_,0,0);
-INFO_TABLE_CONSTR(Dzh_con_info,Hugs_CONSTR_entry,0,sizeofW(StgDouble),0,CONSTR,const,EF_,0,0);
-INFO_TABLE_CONSTR(Azh_con_info,Hugs_CONSTR_entry,0,sizeofW(StgAddr),0,CONSTR,const,EF_,0,0);
-INFO_TABLE_CONSTR(Wzh_con_info,Hugs_CONSTR_entry,0,sizeofW(StgWord),0,CONSTR,const,EF_,0,0);
-INFO_TABLE_CONSTR(StablePtr_con_info,Hugs_CONSTR_entry,0,sizeofW(StgStablePtr),0,CONSTR,const,EF_,0,0);
+INFO_TABLE_CONSTR(Czh_con_info,Hugs_CONSTR_entry,0,sizeofW(StgChar),0,CONSTR,,EF_,0,0);
+INFO_TABLE_CONSTR(Izh_con_info,Hugs_CONSTR_entry,0,sizeofW(StgInt),0,CONSTR,,EF_,0,0);
+INFO_TABLE_CONSTR(I64zh_con_info,Hugs_CONSTR_entry,0,sizeofW(StgInt64),0,CONSTR,,EF_,0,0);
+INFO_TABLE_CONSTR(Fzh_con_info,Hugs_CONSTR_entry,0,sizeofW(StgFloat),0,CONSTR,,EF_,0,0);
+INFO_TABLE_CONSTR(Dzh_con_info,Hugs_CONSTR_entry,0,sizeofW(StgDouble),0,CONSTR,,EF_,0,0);
+INFO_TABLE_CONSTR(Azh_con_info,Hugs_CONSTR_entry,0,sizeofW(StgAddr),0,CONSTR,,EF_,0,0);
+INFO_TABLE_CONSTR(Wzh_con_info,Hugs_CONSTR_entry,0,sizeofW(StgWord),0,CONSTR,,EF_,0,0);
+INFO_TABLE_CONSTR(StablePtr_con_info,Hugs_CONSTR_entry,0,sizeofW(StgStablePtr),0,CONSTR,,EF_,0,0);
/* These might seem redundant but {I,C}zh_static_info are used in
* {INT,CHAR}LIKE and the rest are used in RtsAPI.c
*/
-INFO_TABLE_CONSTR(Czh_static_info,Hugs_CONSTR_entry,0,sizeofW(StgChar),0,CONSTR_NOCAF_STATIC,const,EF_,0,0);
-INFO_TABLE_CONSTR(Izh_static_info,Hugs_CONSTR_entry,0,sizeofW(StgInt),0,CONSTR_NOCAF_STATIC,const,EF_,0,0);
-INFO_TABLE_CONSTR(I64zh_static_info,Hugs_CONSTR_entry,0,sizeofW(StgInt64),0,CONSTR_NOCAF_STATIC,const,EF_,0,0);
-INFO_TABLE_CONSTR(Fzh_static_info,Hugs_CONSTR_entry,0,sizeofW(StgFloat),0,CONSTR_NOCAF_STATIC,const,EF_,0,0);
-INFO_TABLE_CONSTR(Dzh_static_info,Hugs_CONSTR_entry,0,sizeofW(StgDouble),0,CONSTR_NOCAF_STATIC,const,EF_,0,0);
-INFO_TABLE_CONSTR(Azh_static_info,Hugs_CONSTR_entry,0,sizeofW(StgAddr),0,CONSTR_NOCAF_STATIC,const,EF_,0,0);
-INFO_TABLE_CONSTR(Wzh_static_info,Hugs_CONSTR_entry,0,sizeofW(StgWord),0,CONSTR_NOCAF_STATIC,const,EF_,0,0);
-INFO_TABLE_CONSTR(StablePtr_static_info,Hugs_CONSTR_entry,0,sizeofW(StgStablePtr),0,CONSTR_NOCAF_STATIC,const,EF_,0,0);
+INFO_TABLE_CONSTR(Czh_static_info,Hugs_CONSTR_entry,0,sizeofW(StgChar),0,CONSTR_NOCAF_STATIC,,EF_,0,0);
+INFO_TABLE_CONSTR(Izh_static_info,Hugs_CONSTR_entry,0,sizeofW(StgInt),0,CONSTR_NOCAF_STATIC,,EF_,0,0);
+INFO_TABLE_CONSTR(I64zh_static_info,Hugs_CONSTR_entry,0,sizeofW(StgInt64),0,CONSTR_NOCAF_STATIC,,EF_,0,0);
+INFO_TABLE_CONSTR(Fzh_static_info,Hugs_CONSTR_entry,0,sizeofW(StgFloat),0,CONSTR_NOCAF_STATIC,,EF_,0,0);
+INFO_TABLE_CONSTR(Dzh_static_info,Hugs_CONSTR_entry,0,sizeofW(StgDouble),0,CONSTR_NOCAF_STATIC,,EF_,0,0);
+INFO_TABLE_CONSTR(Azh_static_info,Hugs_CONSTR_entry,0,sizeofW(StgAddr),0,CONSTR_NOCAF_STATIC,,EF_,0,0);
+INFO_TABLE_CONSTR(Wzh_static_info,Hugs_CONSTR_entry,0,sizeofW(StgWord),0,CONSTR_NOCAF_STATIC,,EF_,0,0);
+INFO_TABLE_CONSTR(StablePtr_static_info,Hugs_CONSTR_entry,0,sizeofW(StgStablePtr),0,CONSTR_NOCAF_STATIC,,EF_,0,0);
#endif /* !defined(COMPILER) */
replace them with references to the static objects.
-------------------------------------------------------------------------- */
-#ifdef HAVE_WIN32_DLL_SUPPORT
+#ifdef ENABLE_WIN32_DLL_SUPPORT
/*
* When sticking the RTS in a DLL, we delay populating the
* Charlike and Intlike tables until load-time, which is only
* when we've got the real addresses to the C# and I# closures.
*
*/
-static const StgInfoTable czh_static_info;
-static const StgInfoTable izh_static_info;
+static INFO_TBL_CONST StgInfoTable czh_static_info;
+static INFO_TBL_CONST StgInfoTable izh_static_info;
#define Char_hash_static_info czh_static_info
#define Int_hash_static_info izh_static_info
#else
projects / ghc-hetmet.git / blobdiff