X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Frts%2FStgMiscClosures.hc;h=5e966c39099c6a5fad5ace4d5aa11a7be4f9c2a2;hb=0d5d32bf62c39c390934d9ef4b01e2bf2db910f8;hp=3e8cd99527b21598f8259e71263d9c26cb26d8fb;hpb=4391e44f910ce579f269986faef9e5db8907a6c0;p=ghc-hetmet.git diff --git a/ghc/rts/StgMiscClosures.hc b/ghc/rts/StgMiscClosures.hc index 3e8cd99..5e966c3 100644 --- a/ghc/rts/StgMiscClosures.hc +++ b/ghc/rts/StgMiscClosures.hc @@ -1,5 +1,7 @@ /* ----------------------------------------------------------------------------- - * $Id: StgMiscClosures.hc,v 1.3 1999/01/13 17:25:46 simonm Exp $ + * $Id: StgMiscClosures.hc,v 1.37 2000/03/13 10:53:55 simonmar Exp $ + * + * (c) The GHC Team, 1998-1999 * * Entry code for various built-in closure types. * @@ -7,20 +9,48 @@ #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 "Prelude.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 #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_ @@ -28,11 +58,11 @@ STGFUN(IND_entry) 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_ @@ -40,31 +70,53 @@ STGFUN(IND_STATIC_entry) 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_ @@ -72,19 +124,35 @@ STGFUN(IND_OLDGEN_entry) 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_ } @@ -94,7 +162,7 @@ STGFUN(IND_OLDGEN_PERM_entry) This code assumes R1 is in a register for now. -------------------------------------------------------------------------- */ -INFO_TABLE(CAF_UNENTERED_info,CAF_UNENTERED_entry,1,2,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_ @@ -105,12 +173,11 @@ STGFUN(CAF_UNENTERED_entry) FE_ } -INFO_TABLE(CAF_ENTERED_info,CAF_ENTERED_entry,2,1,CAF_ENTERED,const,EF_,0,0); +/* 0,4 is entirely bogus; _do not_ rely on this info */ +INFO_TABLE(CAF_ENTERED_info,CAF_ENTERED_entry,0,4,CAF_ENTERED,,EF_,0,0); STGFUN(CAF_ENTERED_entry) { FB_ - TICK_ENT_CAF_ENTERED(Node); /* tick */ - R1.p = (P_) ((StgCAF*)R1.p)->value; /* just a fancy indirection */ TICK_ENT_VIA_NODE(); JMP_(GET_ENTRY(R1.cl)); @@ -126,43 +193,303 @@ STGFUN(CAF_ENTERED_entry) 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,1,1,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 + { + bdescr *bd = Bdescr(R1.p); + if (bd->back != (bdescr *)BaseReg) { + if (bd->gen->no >= 1 || bd->step->no >= 1) { + CMPXCHG(R1.cl->header.info, &BLACKHOLE_info, &WHITEHOLE_info); + } else { + EXTFUN_RTS(stg_gc_enter_1_hponly); + JMP_(stg_gc_enter_1_hponly); + } + } + } +#endif + TICK_ENT_BH(); + + /* Put ourselves on the blocking queue for this black hole */ +#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,,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 + { + bdescr *bd = Bdescr(R1.p); + if (bd->back != (bdescr *)BaseReg) { + if (bd->gen->no >= 1 || bd->step->no >= 1) { + CMPXCHG(R1.cl->header.info, &BLACKHOLE_info, &WHITEHOLE_info); + } else { + EXTFUN_RTS(stg_gc_enter_1_hponly); + JMP_(stg_gc_enter_1_hponly); + } + } + } +#endif + + TICK_ENT_BH(); + /* Put ourselves on the blocking queue for this black hole */ - CurrentTSO->link = ((StgBlackHole *)R1.p)->blocking_queue; - ((StgBlackHole *)R1.p)->blocking_queue = CurrentTSO; + 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,1,1,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_ - /* Put ourselves on the blocking queue for this black hole */ - CurrentTSO->link = ((StgBlackHole *)R1.p)->blocking_queue; - ((StgBlackHole *)R1.p)->blocking_queue = CurrentTSO; +#if defined(GRAN) + /* mainly statistics gathering for GranSim simulation */ + STGCALL3(GranSimBlock,CurrentTSO,CurrentProc,(StgClosure *)R1.p /*Node*/); +#endif +#ifdef SMP + { + bdescr *bd = Bdescr(R1.p); + if (bd->back != (bdescr *)BaseReg) { + if (bd->gen->no >= 1 || bd->step->no >= 1) { + CMPXCHG(R1.cl->header.info, &CAF_BLACKHOLE_info, &WHITEHOLE_info); + } else { + EXTFUN_RTS(stg_gc_enter_1_hponly); + JMP_(stg_gc_enter_1_hponly); + } + } + } +#endif + + TICK_ENT_BH(); + + /* Put ourselves on the blocking queue for this black hole */ +#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; @@ -174,20 +501,10 @@ EF_(BCO_entry) { /* ----------------------------------------------------------------------------- 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); /* ----------------------------------------------------------------------------- @@ -195,7 +512,7 @@ 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); /* ----------------------------------------------------------------------------- @@ -206,30 +523,50 @@ 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); /* ----------------------------------------------------------------------------- + NO_FINALIZER + + This is a static nullary constructor (like []) that we use to mark an empty + finalizer in a weak pointer object. + -------------------------------------------------------------------------- */ + +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,,EF_,0,0); +NON_ENTERABLE_ENTRY_CODE(STABLE_NAME); + +/* ----------------------------------------------------------------------------- MVars There are two kinds of these: full and empty. We need an info table 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); /* ----------------------------------------------------------------------------- @@ -239,11 +576,11 @@ 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*/,const,EI_) -}; +SET_STATIC_HDR(END_TSO_QUEUE_closure,END_TSO_QUEUE_info,0/*CC*/,,EI_) +, /*payload*/{} }; /* ----------------------------------------------------------------------------- Mutable lists @@ -253,16 +590,29 @@ SET_STATIC_HDR(END_TSO_QUEUE_closure,END_TSO_QUEUE_info,0/*CC*/,const,EI_) 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*/,const,EI_) -}; +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 @@ -277,14 +627,15 @@ NON_ENTERABLE_ENTRY_CODE(MUT_CONS); -------------------------------------------------------------------------- */ -#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); -ArrayInfo(MUT_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 @@ -292,7 +643,7 @@ ArrayInfo(MUT_ARR_PTRS_FROZEN); 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); /* ----------------------------------------------------------------------------- @@ -305,10 +656,8 @@ 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_ \ } @@ -320,7 +669,7 @@ STGFUN(stg_error_entry) \ 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; @@ -328,9 +677,66 @@ FN_(dummy_ret_entry) ret_addr = Sp[0]; Sp++; JMP_(ENTRY_CODE(ret_addr)); + FE_ } -SET_STATIC_HDR(dummy_ret_closure,dummy_ret_info,CCS_DONTZuCARE,const,EI_) -}; +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. + + * -------------------------------------------------------------------------- */ + +#ifdef REG_R1 +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)); +} +#else +INFO_TABLE_SRT_BITMAP(forceIO_ret_info,forceIO_ret_entry,0,0,0,0,RET_SMALL,,EF_,0,0); +FN_(forceIO_ret_entry) +{ + StgClosure *rval; + FB_ + rval = (StgClosure *)Sp[0]; + Sp += 2; + Sp -= sizeofW(StgSeqFrame); + PUSH_SEQ_FRAME(Sp); + R1.cl = rval; + JMP_(GET_ENTRY(R1.cl)); +} +#endif + +INFO_TABLE(forceIO_info,forceIO_entry,1,0,FUN_STATIC,,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) @@ -340,10 +746,8 @@ SET_STATIC_HDR(dummy_ret_closure,dummy_ret_info,CCS_DONTZuCARE,const,EI_) 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) \ @@ -366,32 +770,32 @@ RET_BCO_ENTRY_TEMPLATE(ret_bco_5_entry); 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 +/* 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) */ @@ -403,16 +807,32 @@ INFO_TABLE_CONSTR(StablePtr_static_info,Hugs_CONSTR_entry,0,sizeofW(StgStablePtr replace them with references to the static objects. -------------------------------------------------------------------------- */ +#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 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 +#define Char_hash_static_info Czh_static_info +#define Int_hash_static_info Izh_static_info +#endif + #define CHARLIKE_HDR(n) \ { \ - STATIC_HDR(CZh_static_info, /* C# */ \ + STATIC_HDR(Char_hash_static_info, /* C# */ \ CCS_DONTZuCARE), \ data : n \ } #define INTLIKE_HDR(n) \ { \ - STATIC_HDR(IZh_static_info, /* I# */ \ + STATIC_HDR(Int_hash_static_info, /* I# */ \ CCS_DONTZuCARE), \ data : n \ }