%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: AbsCSyn.lhs,v 1.25 1999/10/31 15:35:32 sof Exp $
+% $Id: AbsCSyn.lhs,v 1.26 1999/11/02 15:05:39 simonmar Exp $
%
\section[AbstractC]{Abstract C: the last stop before machine code}
node = VanillaReg PtrRep ILIT(1) -- A convenient alias for Node
tagreg = VanillaReg WordRep ILIT(2) -- A convenient alias for TagReg
+nodeReg = CReg node
\end{code}
We need magical @Eq@ because @VanillaReg@s come in multiple flavors.
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CLabel.lhs,v 1.28 1999/10/13 16:39:10 simonmar Exp $
+% $Id: CLabel.lhs,v 1.29 1999/11/02 15:05:40 simonmar Exp $
%
\section[CLabel]{@CLabel@: Information to make C Labels}
mkErrorStdEntryLabel,
mkUpdInfoLabel,
mkTopTickyCtrLabel,
+ mkBlackHoleInfoTableLabel,
mkCAFBlackHoleInfoTableLabel,
mkSECAFBlackHoleInfoTableLabel,
mkRtsPrimOpLabel,
mkErrorStdEntryLabel = RtsLabel RtsShouldNeverHappenCode
mkUpdInfoLabel = RtsLabel RtsUpdInfo
mkTopTickyCtrLabel = RtsLabel RtsTopTickyCtr
+mkBlackHoleInfoTableLabel = RtsLabel (RtsBlackHoleInfoTbl SLIT("BLACKHOLE_info"))
mkCAFBlackHoleInfoTableLabel = RtsLabel (RtsBlackHoleInfoTbl SLIT("CAF_BLACKHOLE_info"))
mkSECAFBlackHoleInfoTableLabel = if opt_DoTickyProfiling then
RtsLabel (RtsBlackHoleInfoTbl SLIT("SE_CAF_BLACKHOLE_info"))
where
(pp_saves, pp_restores) = ppr_vol_regs vol_regs
(pp_save_context, pp_restore_context)
- | may_gc = ( text "do { SaveThreadState();"
- , text "LoadThreadState();} while(0);"
+ | may_gc = ( text "do { I_ id; SaveThreadState(); id = suspendThread(BaseReg);"
+ , text "BaseReg = resumeThread(id); LoadThreadState();} while(0);"
)
| otherwise = ( pp_basic_saves $$ pp_saves,
pp_basic_restores $$ pp_restores)
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgClosure.lhs,v 1.36 1999/11/01 17:10:07 simonpj Exp $
+% $Id: CgClosure.lhs,v 1.37 1999/11/02 15:05:43 simonmar Exp $
%
\section[CgClosure]{Code generation for closures}
cl_descr mod_name = closureDescription mod_name (closureName closure_info)
body_label = entryLabelFromCI closure_info
+
is_box = case body of { StgApp fun [] -> True; _ -> False }
body_code = profCtrC SLIT("TICK_ENT_THK") [] `thenC`
thunkChecks lbl node_points (
-- Overwrite with black hole if necessary
- blackHoleIt closure_info node_points `thenC`
+ blackHoleIt closure_info node_points `thenC`
setupUpdate closure_info ( -- setupUpdate *encloses* the rest
blackHoleIt closure_info node_points
= if blackHoleOnEntry closure_info && node_points
then
+ let
+ info_label = infoTableLabelFromCI closure_info
+ args = [ CLbl info_label DataPtrRep ]
+ in
absC (if closureSingleEntry(closure_info) then
- CMacroStmt UPD_BH_SINGLE_ENTRY [CReg node]
+ CMacroStmt UPD_BH_SINGLE_ENTRY args
else
- CMacroStmt UPD_BH_UPDATABLE [CReg node])
+ CMacroStmt UPD_BH_UPDATABLE args)
else
nopC
\end{code}
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgTailCall.lhs,v 1.22 1999/06/22 08:00:00 simonpj Exp $
+% $Id: CgTailCall.lhs,v 1.23 1999/11/02 15:05:43 simonmar Exp $
%
%********************************************************
%* *
import CgStackery ( mkTaggedStkAmodes, adjustStackHW )
import CgUsages ( getSpRelOffset, adjustSpAndHp )
import CgUpdate ( pushSeqFrame )
-import CLabel ( mkUpdInfoLabel, mkRtsPrimOpLabel )
+import CLabel ( mkUpdInfoLabel, mkRtsPrimOpLabel,
+ mkBlackHoleInfoTableLabel )
import ClosureInfo ( nodeMustPointToIt,
getEntryConvention, EntryConvention(..),
LambdaFormInfo
import TyCon ( TyCon )
import PrimOp ( PrimOp )
import Util ( zipWithEqual )
+import Unique ( mkPseudoUnique1 )
import Outputable
import Panic ( panic, assertPanic )
\end{code}
(fast_stk_amodes, tagged_stk_amodes) =
splitAt arity stk_arg_amodes
+
+ -- eager blackholing, at the end of the basic block.
+ node_save = CTemp (mkPseudoUnique1 2) DataPtrRep
+ (r1_tmp_asst, bh_asst)
+ = case sequel of
+#if 0
+ -- no: UpdateCode doesn't tell us that we're in a thunk's entry code.
+ -- we might be in a case continuation later down the line. Also,
+ -- we might have pushed a return address on the stack, if we're in
+ -- a case scrut, and still be in the thunk's entry code.
+ UpdateCode ->
+ (CAssign node_save nodeReg,
+ CAssign (CVal (CIndex node_save (mkIntCLit 0) PtrRep)
+ PtrRep)
+ (CLbl mkBlackHoleInfoTableLabel DataPtrRep))
+#endif
+ _ -> (AbsCNop, AbsCNop)
in
-- We can omit tags on the arguments passed to the fast entry point,
-- but we have to be careful to fill in the tags on any *extra*
-- The stack space for the pushed return addess,
-- with any args pushed on top, is recorded in final_sp.
- -- Do the simultaneous assignments,
- doSimAssts (mkAbstractCs [pending_assts,
+ -- Do the simultaneous assignments,
+ doSimAssts (mkAbstractCs [r1_tmp_asst,
+ pending_assts,
reg_arg_assts,
fast_arg_assts,
tagged_arg_assts,
tag_assts]) `thenC`
+ absC bh_asst `thenC`
-- push a return address if necessary
-- (after the assignments above, in case we clobber a live
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: ClosureInfo.lhs,v 1.38 1999/05/18 15:03:50 simonpj Exp $
+% $Id: ClosureInfo.lhs,v 1.39 1999/11/02 15:05:44 simonmar Exp $
%
\section[ClosureInfo]{Data structures which describe closures}
mkReturnPtLabel
)
import CmdLineOpts ( opt_SccProfilingOn, opt_OmitBlackHoling,
- opt_Parallel, opt_DoTickyProfiling )
+ opt_Parallel, opt_DoTickyProfiling,
+ opt_SMP )
import Id ( Id, idType, getIdArity )
import DataCon ( DataCon, dataConTag, fIRST_TAG,
isNullaryDataCon, isTupleCon, dataConName
LFThunk _ _ _ updatable std_form_info _ _
-> if updatable || opt_DoTickyProfiling -- to catch double entry
+ || opt_SMP -- always enter via node on SMP, since the
+ -- thunk might have been blackholed in the
+ -- meantime.
then ViaNode
else StdEntry (thunkEntryLabel name std_form_info updatable)
opt_IrrefutableTuples,
opt_NumbersStrict,
opt_Parallel,
+ opt_SMP,
-- optimisation opts
opt_DoEtaReduction,
opt_MaxContextReductionDepth = lookup_def_int "-fcontext-stack" mAX_CONTEXT_REDUCTION_DEPTH
opt_NumbersStrict = lookUp SLIT("-fnumbers-strict")
opt_Parallel = lookUp SLIT("-fparallel")
+opt_SMP = lookUp SLIT("-fsmp")
-- optimisation opts
opt_DoEtaReduction = lookUp SLIT("-fdo-eta-reduction")
'_p', "-fscc-profiling -DPROFILING -optc-DPROFILING",
'_t', "-fticky-ticky -DTICKY_TICKY -optc-DTICKY_TICKY",
'_u', "-optc-DNO_REGS -optc-DUSE_MINIINTERPRETER -fno-asm-mangling -funregisterised",
- '_s', "-fparallel -optc-pthread -optl-pthread -optc-DSMP",
+ '_s', "-fsmp -optc-pthread -optl-pthread -optc-DSMP",
'_mp', "-fparallel -D__PARALLEL_HASKELL__ -optc-DPAR",
'_mg', "-fgransim -D__GRANSIM__ -optc-DGRAN");
/^-fticky-ticky$/ && do { push(@HsC_flags,$_); next arg; };
/^-fgransim$/ && do { push(@HsC_flags,$_); next arg; };
/^-fparallel$/ && do { push(@HsC_flags,$_); next arg; };
+ /^-fsmp$/ && do { push(@HsC_flags,$_); next arg; };
/^-split-objs$/ && do {
if ( $TargetPlatform !~ /^(alpha|hppa1\.1|i386|m68k|mips|powerpc|rs6000|sparc)-/ ) {
/* -----------------------------------------------------------------------------
- * $Id: MachRegs.h,v 1.5 1999/06/25 09:13:38 simonmar Exp $
+ * $Id: MachRegs.h,v 1.6 1999/11/02 15:05:50 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
#define REG_Base ebx
#endif
#define REG_Sp ebp
+/* #define REG_Su ebx*/
#if STOLEN_X86_REGS >= 3
# define REG_R1 esi
/* -----------------------------------------------------------------------------
- * $Id: PrimOps.h,v 1.37 1999/08/25 16:11:43 simonmar Exp $
+ * $Id: PrimOps.h,v 1.38 1999/11/02 15:05:51 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
EF_(yieldzh_fast);
EF_(killThreadzh_fast);
EF_(seqzh_fast);
+EF_(unblockExceptionszh_fast);
+
+#define blockExceptionszh_fast \
+ if (CurrentTSO->pending_exceptions == NULL) { \
+ CurrentTSO->pending_exceptions = &END_EXCEPTION_LIST_closure; \
+ }
#define myThreadIdzh(t) (t = CurrentTSO)
/* -----------------------------------------------------------------------------
- * $Id: Regs.h,v 1.4 1999/03/02 19:44:14 sof Exp $
+ * $Id: Regs.h,v 1.5 1999/11/02 15:05:51 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
* 2) caller-saves registers are saved across a CCall
*/
-typedef struct {
+typedef struct StgRegTable_ {
StgUnion rR1;
StgUnion rR2;
StgUnion rR3;
StgPtr rSpLim;
StgPtr rHp;
StgPtr rHpLim;
+ StgTSO *rCurrentTSO;
+ bdescr *rNursery;
+ bdescr *rCurrentNursery;
+#ifdef SMP
+ struct StgRegTable_ *link;
+#endif
} StgRegTable;
+/* No such thing as a MainRegTable under SMP - each thread must
+ * have its own MainRegTable.
+ */
+#ifndef SMP
extern DLL_IMPORT_RTS StgRegTable MainRegTable;
+#endif
+
+#ifdef IN_STG_CODE
/*
* Registers Hp and HpLim are global across the entire system, and are
#define SAVE_Su (CurrentTSO->su)
#define SAVE_SpLim (CurrentTSO->splim)
-#define SAVE_Hp (MainRegTable.rHp)
-#define SAVE_HpLim (MainRegTable.rHpLim)
+#define SAVE_Hp (BaseReg->rHp)
+#define SAVE_HpLim (BaseReg->rHpLim)
+
+#define SAVE_CurrentTSO (BaseReg->rCurrentTSO)
+#define SAVE_CurrentNursery (BaseReg->rCurrentNursery)
/* We sometimes need to save registers across a C-call, eg. if they
* are clobbered in the standard calling convention. We define the
* save locations for all registers in the register table.
*/
-#define SAVE_R1 (MainRegTable.rR1)
-#define SAVE_R2 (MainRegTable.rR2)
-#define SAVE_R3 (MainRegTable.rR3)
-#define SAVE_R4 (MainRegTable.rR4)
-#define SAVE_R5 (MainRegTable.rR5)
-#define SAVE_R6 (MainRegTable.rR6)
-#define SAVE_R7 (MainRegTable.rR7)
-#define SAVE_R8 (MainRegTable.rR8)
+#define SAVE_R1 (BaseReg->rR1)
+#define SAVE_R2 (BaseReg->rR2)
+#define SAVE_R3 (BaseReg->rR3)
+#define SAVE_R4 (BaseReg->rR4)
+#define SAVE_R5 (BaseReg->rR5)
+#define SAVE_R6 (BaseReg->rR6)
+#define SAVE_R7 (BaseReg->rR7)
+#define SAVE_R8 (BaseReg->rR8)
-#define SAVE_F1 (MainRegTable.rF1)
-#define SAVE_F2 (MainRegTable.rF2)
-#define SAVE_F3 (MainRegTable.rF3)
-#define SAVE_F4 (MainRegTable.rF4)
+#define SAVE_F1 (BaseReg->rF1)
+#define SAVE_F2 (BaseReg->rF2)
+#define SAVE_F3 (BaseReg->rF3)
+#define SAVE_F4 (BaseReg->rF4)
-#define SAVE_D1 (MainRegTable.rD1)
-#define SAVE_D2 (MainRegTable.rD2)
+#define SAVE_D1 (BaseReg->rD1)
+#define SAVE_D2 (BaseReg->rD2)
-#define SAVE_L1 (MainRegTable.rL1)
+#define SAVE_L1 (BaseReg->rL1)
/* -----------------------------------------------------------------------------
* Emit the GCC-specific register declarations for each machine
#ifdef REG_Base
GLOBAL_REG_DECL(StgRegTable *,BaseReg,REG_Base)
#else
+#ifdef SMP
+#error BaseReg must be in a register for SMP
+#endif
#define BaseReg (&MainRegTable)
#endif
#define HpLim (BaseReg->rHpLim)
#endif
+#ifdef REG_CurrentTSO
+GLOBAL_REG_DECL(StgTSO *,CurrentTSO,REG_CurrentTSO)
+#else
+#define CurrentTSO (BaseReg->rCurrentTSO)
+#endif
+
+#ifdef REG_CurrentNursery
+GLOBAL_REG_DECL(bdescr *,CurrentNursery,REG_CurrentNursery)
+#else
+#define CurrentNursery (BaseReg->rCurrentNursery)
+#endif
+
/* -----------------------------------------------------------------------------
For any registers which are denoted "caller-saves" by the C calling
convention, we have to emit code to save and restore them across C
#endif
#ifdef CALLER_SAVES_Base
+#ifdef SMP
+#error "Can't have caller-saved BaseReg with SMP"
+#endif
#define CALLER_SAVE_Base /* nothing */
#define CALLER_RESTORE_Base BaseReg = &MainRegTable;
#else
#define CALLER_RESTORE_Base /* nothing */
#endif
+#ifdef CALLER_SAVES_CurrentTSO
+#define CALLER_SAVE_CurrentTSO SAVE_CurrentTSO = CurrentTSO;
+#define CALLER_RESTORE_CurrentTSO CurrentTSO = SAVE_CurrentTSO;
+#else
+#define CALLER_SAVE_CurrentTSO /* nothing */
+#define CALLER_RESTORE_CurrentTSO /* nothing */
+#endif
+
+#ifdef CALLER_SAVES_CurrentNursery
+#define CALLER_SAVE_CurrentNursery SAVE_CurrentNursery = CurrentNursery;
+#define CALLER_RESTORE_CurrentNursery CurrentNursery = SAVE_CurrentNursery;
+#else
+#define CALLER_SAVE_CurrentNursery /* nothing */
+#define CALLER_RESTORE_CurrentNursery /* nothing */
+#endif
+
+#endif /* IN_STG_CODE */
+
/* ----------------------------------------------------------------------------
Handy bunches of saves/restores
------------------------------------------------------------------------ */
+#ifdef IN_STG_CODE
+
#define CALLER_SAVE_USER \
CALLER_SAVE_R1 \
CALLER_SAVE_R2 \
CALLER_SAVE_Su \
CALLER_SAVE_SpLim \
CALLER_SAVE_Hp \
- CALLER_SAVE_HpLim
+ CALLER_SAVE_HpLim \
+ CALLER_SAVE_CurrentTSO \
+ CALLER_SAVE_CurrentNursery
#define CALLER_RESTORE_USER \
CALLER_RESTORE_R1 \
CALLER_RESTORE_Su \
CALLER_RESTORE_SpLim \
CALLER_RESTORE_Hp \
- CALLER_RESTORE_HpLim
+ CALLER_RESTORE_HpLim \
+ CALLER_RESTORE_CurrentTSO \
+ CALLER_RESTORE_CurrentNursery
+
+#else /* not IN_STG_CODE */
+
+#define CALLER_SAVE_USER /* nothing */
+#define CALLER_SAVE_SYSTEM /* nothing */
+#define CALLER_RESTORE_USER /* nothing */
+#define CALLER_RESTORE_SYSTEM /* nothing */
+
+#endif /* IN_STG_CODE */
#define CALLER_SAVE_ALL \
CALLER_SAVE_SYSTEM \
/* -----------------------------------------------------------------------------
- * $Id: Rts.h,v 1.7 1999/08/25 16:11:44 simonmar Exp $
+ * $Id: Rts.h,v 1.8 1999/11/02 15:05:52 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
#ifndef RTS_H
#define RTS_H
-#ifndef NO_REGS
-#define NO_REGS /* don't define fixed registers */
+#ifndef IN_STG_CODE
+#define NOT_IN_STG_CODE
#endif
#include "Stg.h"
/* ----------------------------------------------------------------------------
- * $Id: RtsAPI.h,v 1.7 1999/07/06 09:42:39 sof Exp $
+ * $Id: RtsAPI.h,v 1.8 1999/11/02 15:05:52 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
* Running the scheduler
*/
typedef enum {
+ NoStatus, /* not finished yet */
Success,
Killed, /* another thread killed us */
Interrupted, /* stopped in response to a call to interruptStgRts */
--- /dev/null
+/* ----------------------------------------------------------------------------
+ * $Id: SMP.h,v 1.1 1999/11/02 15:05:52 simonmar Exp $
+ *
+ * (c) The GHC Team, 1999
+ *
+ * Macros for SMP support
+ *
+ * -------------------------------------------------------------------------- */
+
+#ifndef SMP_H
+#define SMP_H
+
+/* SMP is currently not compatible with the following options:
+ *
+ * INTERPRETER
+ * PROFILING
+ * TICKY_TICKY
+ * and unregisterised builds.
+ */
+
+#if defined(SMP)
+
+#if defined(INTERPRETER) \
+ || defined(PROFILING) \
+ || defined(TICKY_TICKY)
+#error Build options incompatible with SMP.
+#endif
+
+/*
+ * CMPXCHG - this instruction is the standard "test & set". We use it
+ * for locking closures in the thunk and blackhole entry code. If the
+ * closure is already locked, or has an unexpected info pointer
+ * (because another thread is altering it in parallel), we just jump
+ * to the new entry point.
+ */
+#if defined(i386_TARGET_ARCH) && defined(TABLES_NEXT_TO_CODE)
+#define CMPXCHG(p, cmp, new) \
+ __asm__ __volatile__ ( \
+ "lock ; cmpxchg %1, %0\n" \
+ "\tje 1f\n" \
+ "\tjmp *%%eax\n" \
+ "\t1:\n" \
+ : /* no outputs */ \
+ : "m" (p), "r" (new), "r" (cmp) \
+ )
+
+/*
+ * XCHG - the atomic exchange instruction. Used for locking closures
+ * during updates (see LOCK_CLOSURE below) and the MVar primops.
+ */
+#define XCHG(reg, obj) \
+ __asm__ __volatile__ ( \
+ "xchgl %1,%0" \
+ :"+r" (reg), "+m" (obj) \
+ : /* no input-only operands */ \
+ )
+
+#else
+#error SMP macros not defined for this architecture
+#endif
+
+/*
+ * LOCK_CLOSURE locks the specified closure, busy waiting for any
+ * existing locks to be cleared.
+ */
+#define LOCK_CLOSURE(c) \
+ ({ \
+ const StgInfoTable *__info; \
+ __info = &WHITEHOLE_info; \
+ do { \
+ XCHG(__info,((StgClosure *)(c))->header.info); \
+ } while (__info == &WHITEHOLE_info); \
+ __info; \
+ })
+
+#define LOCK_THUNK(__info) \
+ CMPXCHG(R1.cl->header.info, __info, &WHITEHOLE_info);
+
+#define ACQUIRE_LOCK(mutex) pthread_mutex_lock(mutex);
+#define RELEASE_LOCK(mutex) pthread_mutex_unlock(mutex);
+
+#else /* !SMP */
+
+#define LOCK_CLOSURE(c) /* nothing */
+#define LOCK_THUNK(__info) /* nothing */
+#define ACQUIRE_LOCK(mutex) /* nothing */
+#define RELEASE_LOCK(mutex) /* nothing */
+
+#endif /* SMP */
+
+#endif /* SMP_H */
/* -----------------------------------------------------------------------------
- * $Id: SchedAPI.h,v 1.6 1999/07/06 09:42:39 sof Exp $
+ * $Id: SchedAPI.h,v 1.7 1999/11/02 15:05:52 simonmar Exp $
*
* (c) The GHC Team 1998
*
* not compiling rts/ bits. -- sof 7/99
*
*/
-SchedulerStatus schedule(StgTSO *main_thread, /*out*/StgClosure **ret);
+SchedulerStatus waitThread(StgTSO *main_thread, /*out*/StgClosure **ret);
/*
* Creating threads
*/
-StgTSO *createThread (nat stack_size);
+StgTSO *createThread(nat stack_size);
+void scheduleThread(StgTSO *tso);
static inline void pushClosure (StgTSO *tso, StgClosure *c) {
tso->sp--;
/* -----------------------------------------------------------------------------
- * $Id: Stg.h,v 1.17 1999/07/06 09:42:39 sof Exp $
+ * $Id: Stg.h,v 1.18 1999/11/02 15:05:52 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
#define _POSIX_SOURCE
#endif
+/* If we include "Stg.h" directly, we're in STG code, and we therefore
+ * get all the global register variables, macros etc. that go along
+ * with that. If "Stg.h" is included via "Rts.h", we're assumed to
+ * be in vanilla C.
+ */
+#ifdef NOT_IN_STG_CODE
+#define NO_REGS /* don't define fixed registers */
+#else
+#define IN_STG_CODE
+#endif
+
/* Configuration */
#include "config.h"
#ifdef __HUGS__ /* vile hack till the GHC folks come on board */
* For now, do lazy and not eager.
*/
-#define LAZY_BLACKHOLING
-/* #define EAGER_BLACKHOLING */
-
-#ifdef TICKY_TICKY
-/* TICKY_TICKY needs EAGER_BLACKHOLING to verify no double-entries of single-entry thunks. */
-# undef LAZY_BLACKHOLING
-# define EAGER_BLACKHOLING
+/* TICKY_TICKY needs EAGER_BLACKHOLING to verify no double-entries of
+ * single-entry thunks.
+ *
+ * SMP needs EAGER_BLACKHOLING because it has to lock thunks
+ * synchronously, in case another thread is trying to evaluate the
+ * same thunk simultaneously.
+ */
+#if defined(SMP) || defined(TICKY_TICKY)
+# define EAGER_BLACKHOLING
+#else
+# define LAZY_BLACKHOLING
#endif
/* ToDo: Set this flag properly: COMPILER and INTERPRETER should not be mutually exclusive. */
#include "ClosureTypes.h"
#include "InfoTables.h"
#include "TSO.h"
+#include "Block.h"
/* STG/Optimised-C related stuff */
+#include "SMP.h"
#include "MachRegs.h"
#include "Regs.h"
#include "TailCalls.h"
#include <unistd.h>
#endif
+#ifdef SMP
+#include <pthread.h>
+#endif
+
/* GNU mp library */
#include "gmp.h"
/* -----------------------------------------------------------------------------
- * $Id: StgMacros.h,v 1.13 1999/10/13 16:39:21 simonmar Exp $
+ * $Id: StgMacros.h,v 1.14 1999/11/02 15:05:52 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
#define SET_TAG(t) /* nothing */
#ifdef EAGER_BLACKHOLING
-# define UPD_BH_UPDATABLE(thunk) \
- TICK_UPD_BH_UPDATABLE(); \
- SET_INFO((StgClosure *)thunk,&BLACKHOLE_info)
-# define UPD_BH_SINGLE_ENTRY(thunk) \
- TICK_UPD_BH_SINGLE_ENTRY(); \
- SET_INFO((StgClosure *)thunk,&SE_BLACKHOLE_info)
+# ifdef SMP
+# define UPD_BH_UPDATABLE(info) \
+ TICK_UPD_BH_UPDATABLE(); \
+ LOCK_THUNK(info); \
+ SET_INFO(R1.cl,&BLACKHOLE_info)
+# define UPD_BH_SINGLE_ENTRY(info) \
+ TICK_UPD_BH_SINGLE_ENTRY(); \
+ LOCK_THUNK(info); \
+ SET_INFO(R1.cl,&BLACKHOLE_info)
+# else
+# define UPD_BH_UPDATABLE(info) \
+ TICK_UPD_BH_UPDATABLE(); \
+ SET_INFO(R1.cl,&BLACKHOLE_info)
+# define UPD_BH_SINGLE_ENTRY(info) \
+ TICK_UPD_BH_SINGLE_ENTRY(); \
+ SET_INFO(R1.cl,&SE_BLACKHOLE_info)
+# endif
#else /* !EAGER_BLACKHOLING */
# define UPD_BH_UPDATABLE(thunk) /* nothing */
# define UPD_BH_SINGLE_ENTRY(thunk) /* nothing */
We save all the STG registers (that is, the ones that are mapped to
machine registers) in their places in the TSO.
- The stack registers go into the current stack object, and the heap
- registers are saved in global locations.
+ The stack registers go into the current stack object, and the
+ current nursery is updated from the heap pointer.
+
+ These functions assume that BaseReg is loaded appropriately (if
+ we have one).
-------------------------------------------------------------------------- */
+#ifndef NO_REGS
+
static __inline__ void
SaveThreadState(void)
{
CurrentTSO->splim = SpLim;
CloseNursery(Hp);
+#ifdef REG_CurrentTSO
+ SAVE_CurrentTSO = CurrentTSO;
+#endif
+#ifdef REG_CurrentNursery
+ SAVE_CurrentNursery = CurrentNursery;
+#endif
#if defined(PROFILING)
CurrentTSO->prof.CCCS = CCCS;
#endif
static __inline__ void
LoadThreadState (void)
{
-#ifdef REG_Base
- BaseReg = (StgRegTable*)&MainRegTable;
-#endif
-
Sp = CurrentTSO->sp;
Su = CurrentTSO->su;
SpLim = CurrentTSO->splim;
OpenNursery(Hp,HpLim);
+#ifdef REG_CurrentTSO
+ CurrentTSO = SAVE_CurrentTSO;
+#endif
+#ifdef REG_CurrentNursery
+ CurrentNursery = SAVE_CurrentNursery;
+#endif
# if defined(PROFILING)
CCCS = CurrentTSO->prof.CCCS;
# endif
}
+/*
+ * Suspending/resuming threads for doing external C-calls (_ccall_GC).
+ * These functions are defined in rts/Schedule.c.
+ */
+StgInt suspendThread ( StgRegTable *cap );
+StgRegTable * resumeThread ( StgInt );
+
+#endif /* NO_REGS */
+
#endif /* STGMACROS_H */
/* -----------------------------------------------------------------------------
- * $Id: StgMiscClosures.h,v 1.14 1999/07/06 16:17:40 sewardj Exp $
+ * $Id: StgMiscClosures.h,v 1.15 1999/11/02 15:05:53 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
STGFUN(CAF_BLACKHOLE_entry);
STGFUN(BLACKHOLE_entry);
STGFUN(BLACKHOLE_BQ_entry);
+#ifdef SMP
+STGFUN(WHITEHOLE_entry);
+#endif
#ifdef TICKY_TICKY
STGFUN(SE_BLACKHOLE_entry);
STGFUN(SE_CAF_BLACKHOLE_entry);
extern DLL_IMPORT_RTS const StgInfoTable CAF_BLACKHOLE_info;
extern DLL_IMPORT_RTS const StgInfoTable BLACKHOLE_info;
extern DLL_IMPORT_RTS const StgInfoTable BLACKHOLE_BQ_info;
+#ifdef SMP
+extern DLL_IMPORT_RTS const StgInfoTable WHITEHOLE_info;
+#endif
#ifdef TICKY_TICKY
extern DLL_IMPORT_RTS const StgInfoTable SE_BLACKHOLE_info;
extern DLL_IMPORT_RTS const StgInfoTable SE_CAF_BLACKHOLE_info;
/* -----------------------------------------------------------------------------
- * $Id: StgStorage.h,v 1.4 1999/03/02 19:44:21 sof Exp $
+ * $Id: StgStorage.h,v 1.5 1999/11/02 15:05:53 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
#ifndef STGSTORAGE_H
#define STGSTORAGE_H
-#include "Block.h"
-
-extern DLL_IMPORT_RTS bdescr *current_nursery;
-
/* -----------------------------------------------------------------------------
Allocation area for compiled code
-------------------------------------------------------------------------- */
#define OpenNursery(hp,hplim) \
- (hp = current_nursery->free-1, \
- hplim = current_nursery->start + BLOCK_SIZE_W - 1)
+ (hp = CurrentNursery->free-1, \
+ hplim = CurrentNursery->start + BLOCK_SIZE_W - 1)
-#define CloseNursery(hp) (current_nursery->free = (P_)(hp)+1)
+#define CloseNursery(hp) (CurrentNursery->free = (P_)(hp)+1)
/* -----------------------------------------------------------------------------
Trigger a GC from Haskell land.
/* -----------------------------------------------------------------------------
- * $Id: Updates.h,v 1.13 1999/10/20 10:14:47 simonmar Exp $
+ * $Id: Updates.h,v 1.14 1999/11/02 15:05:53 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
/* UPD_IND actually does a PERM_IND if TICKY_TICKY is on;
if you *really* need an IND use UPD_REAL_IND
*/
-#define UPD_REAL_IND(updclosure, heapptr) \
- AWAKEN_BQ(updclosure); \
+#ifdef SMP
+#define UPD_REAL_IND(updclosure, heapptr) \
+ { \
+ const StgInfoTable *info; \
+ info = LOCK_CLOSURE(updclosure); \
+ \
+ if (info == &BLACKHOLE_BQ_info) { \
+ STGCALL1(awakenBlockedQueue, \
+ ((StgBlockingQueue *)updclosure)->blocking_queue); \
+ } \
updateWithIndirection((StgClosure *)updclosure, \
+ (StgClosure *)heapptr); \
+ }
+#else
+#define UPD_REAL_IND(updclosure, heapptr) \
+ AWAKEN_BQ(updclosure); \
+ updateWithIndirection((StgClosure *)updclosure, \
(StgClosure *)heapptr);
+#endif
#if defined(PROFILING) || defined(TICKY_TICKY)
#define UPD_PERM_IND(updclosure, heapptr) \
extern void newCAF(StgClosure*);
-#define UPD_CAF(cafptr, bhptr) \
- { \
- SET_INFO((StgInd *)cafptr,(const StgInfoTable*)&IND_STATIC_info); \
- ((StgInd *)cafptr)->indirectee = (StgClosure *)(bhptr); \
- STGCALL1(newCAF,(StgClosure *)cafptr); \
+#define UPD_CAF(cafptr, bhptr) \
+ { \
+ LOCK_CLOSURE(cafptr); \
+ ((StgInd *)cafptr)->indirectee = (StgClosure *)(bhptr); \
+ SET_INFO((StgInd *)cafptr,(const StgInfoTable*)&IND_STATIC_info); \
+ STGCALL1(newCAF,(StgClosure *)cafptr); \
}
/* -----------------------------------------------------------------------------
/* -----------------------------------------------------------------------------
- * $Id: BlockAlloc.h,v 1.5 1999/02/05 16:02:36 simonm Exp $
+ * $Id: BlockAlloc.h,v 1.6 1999/11/02 15:05:56 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
/* Finding the block descriptor for a given block -------------------------- */
-static inline bdescr *Bdescr(StgPtr p)
+extern inline bdescr *Bdescr(StgPtr p)
{
return (bdescr *)
((((W_)p & MBLOCK_MASK & ~BLOCK_MASK) >> (BLOCK_SHIFT-BDESCR_SHIFT))
/* -----------------------------------------------------------------------------
- * $Id: ClosureFlags.c,v 1.2 1999/05/11 16:47:49 keithw Exp $
+ * $Id: ClosureFlags.c,v 1.3 1999/11/02 15:05:56 simonmar Exp $
*
* (c) The GHC Team 1998-1999
*
/* IND_STATIC */ ( _STA ),
/* CAF_UNENTERED */ ( 0 ),
/* CAF_ENTERED */ ( 0 ),
-/* CAF_BLACKHOLE */ ( _BTM|_NS| _UPT ),
+/* BLACKHOLE_BQ */ ( _BTM|_NS| _MUT|_UPT ),
/* RET_BCO */ ( _BTM ),
/* RET_SMALL */ ( _BTM| _SRT),
/* RET_VEC_SMALL */ ( _BTM| _SRT),
/* -----------------------------------------------------------------------------
- * $Id: GC.c,v 1.64 1999/11/01 18:17:45 sewardj Exp $
+ * $Id: GC.c,v 1.65 1999/11/02 15:05:56 simonmar Exp $
*
* (c) The GHC Team 1998-1999
*
CCCS = CCS_GC;
#endif
- /* We might have been called from Haskell land by _ccall_GC, in
- * which case we need to call threadPaused() because the scheduler
- * won't have done it.
- */
- if (CurrentTSO) { threadPaused(CurrentTSO); }
-
- /* Approximate how much we allocated: number of blocks in the
- * nursery + blocks allocated via allocate() - unused nusery blocks.
- * This leaves a little slop at the end of each block, and doesn't
- * take into account large objects (ToDo).
- */
- allocated = (nursery_blocks * BLOCK_SIZE_W) + allocated_bytes();
- for ( bd = current_nursery->link; bd != NULL; bd = bd->link ) {
- allocated -= BLOCK_SIZE_W;
- }
- if (current_nursery->free < current_nursery->start + BLOCK_SIZE_W) {
- allocated -= (current_nursery->start + BLOCK_SIZE_W)
- - current_nursery->free;
- }
+ /* Approximate how much we allocated */
+ allocated = calcAllocated();
/* Figure out which generation to collect
*/
evac_gen = 0;
get_roots();
- /* And don't forget to mark the TSO if we got here direct from
- * Haskell! */
- if (CurrentTSO) {
- CurrentTSO = (StgTSO *)MarkRoot((StgClosure *)CurrentTSO);
- }
-
/* Mark the weak pointer list, and prepare to detect dead weak
* pointers.
*/
/* Reset the nursery
*/
- for (bd = g0s0->blocks; bd; bd = bd->link) {
- bd->free = bd->start;
- ASSERT(bd->gen == g0);
- ASSERT(bd->step == g0s0);
- IF_DEBUG(sanity,memset(bd->start, 0xaa, BLOCK_SIZE));
- }
- current_nursery = g0s0->blocks;
+ resetNurseries();
/* start any pending finalizers */
scheduleFinalizers(old_weak_ptr_list);
#endif
TICK_UPD_SQUEEZED();
- /* wasn't there something about update squeezing and ticky to be sorted out?
- * oh yes: we aren't counting each enter properly in this case. See the log somewhere.
- * KSW 1999-04-21 */
+ /* wasn't there something about update squeezing and ticky to be
+ * sorted out? oh yes: we aren't counting each enter properly
+ * in this case. See the log somewhere. KSW 1999-04-21
+ */
UPD_IND(updatee_bypass, updatee_keep); /* this wakes the threads up */
sp = (P_)frame - 1; /* sp = stuff to slide */
/* -----------------------------------------------------------------------------
- * $Id: Main.c,v 1.11 1999/09/16 08:29:01 sof Exp $
+ * $Id: Main.c,v 1.12 1999/11/02 15:05:58 simonmar Exp $
*
* (c) The GHC Team 1998-1999
*
#include "RtsAPI.h"
#include "SchedAPI.h"
#include "RtsFlags.h"
-#include "Schedule.h" /* for MainTSO */
#include "RtsUtils.h"
#ifdef DEBUG
startupHaskell(argc,argv);
# ifndef PAR
- MainTSO = createIOThread(stg_max(BLOCK_SIZE_W,
- RtsFlags.GcFlags.initialStkSize),
- (StgClosure *)&mainIO_closure);
- status = schedule(MainTSO,NULL);
+ /* ToDo: want to start with a larger stack size */
+ status = rts_evalIO((StgClosure *)&mainIO_closure, NULL);
# else
if (IAmMainThread == rtsTrue) {
/*Just to show we're alive */
fprintf(stderr, "Main Thread Started ...\n");
- MainTSO = createIOThread(stg_max(BLOCK_SIZE_W,
- RtsFlags.GcFlags.initialStkSize),
- (StgClosure *)&mainIO_closure);
- status = schedule(MainTSO,NULL);
+ status = rts_evalIO((StgClosure *)&mainIO_closure, NULL);
} else {
WaitForPEOp(PP_FINISH,SysManTask);
exit(EXIT_SUCCESS);
/* -----------------------------------------------------------------------------
- * $Id: PrimOps.hc,v 1.32 1999/10/15 09:50:22 simonmar Exp $
+ * $Id: PrimOps.hc,v 1.33 1999/11/02 15:05:58 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
/* create it right now, return ThreadID in R1 */
R1.t = RET_STGCALL2(StgTSO *, createIOThread,
RtsFlags.GcFlags.initialStkSize, R1.cl);
+ STGCALL1(scheduleThread, R1.t);
/* switch at the earliest opportunity */
context_switch = 1;
{
StgMVar *mvar;
StgClosure *val;
+ const StgInfoTable *info;
FB_
/* args: R1 = MVar closure */
mvar = (StgMVar *)R1.p;
+#ifdef SMP
+ info = LOCK_CLOSURE(mvar);
+#else
+ info = GET_INFO(mvar);
+#endif
+
/* If the MVar is empty, put ourselves on its blocking queue,
* and wait until we're woken up.
*/
- if (GET_INFO(mvar) != &FULL_MVAR_info) {
+ if (info == &EMPTY_MVAR_info) {
if (mvar->head == (StgTSO *)&END_TSO_QUEUE_closure) {
mvar->head = CurrentTSO;
} else {
CurrentTSO->block_info.closure = (StgClosure *)mvar;
mvar->tail = CurrentTSO;
+#ifdef SMP
+ /* unlock the MVar */
+ mvar->header.info = &EMPTY_MVAR_info;
+#endif
BLOCK(R1_PTR, takeMVarzh_fast);
}
- SET_INFO(mvar,&EMPTY_MVAR_info);
val = mvar->value;
mvar->value = (StgClosure *)&END_TSO_QUEUE_closure;
+ /* do this last... we might have locked the MVar in the SMP case,
+ * and writing the info pointer will unlock it.
+ */
+ SET_INFO(mvar,&EMPTY_MVAR_info);
+
TICK_RET_UNBOXED_TUP(1);
RET_P(val);
FE_
FN_(putMVarzh_fast)
{
StgMVar *mvar;
+ const StgInfoTable *info;
FB_
/* args: R1 = MVar, R2 = value */
mvar = (StgMVar *)R1.p;
- if (GET_INFO(mvar) == &FULL_MVAR_info) {
+
+#ifdef SMP
+ info = LOCK_CLOSURE(mvar);
+#else
+ info = GET_INFO(mvar);
+#endif
+
+ if (info == &FULL_MVAR_info) {
fprintf(stderr, "putMVar#: MVar already full.\n");
stg_exit(EXIT_FAILURE);
}
- SET_INFO(mvar,&FULL_MVAR_info);
mvar->value = R2.cl;
/* wake up the first thread on the queue, it will continue with the
}
}
+ /* unlocks the MVar in the SMP case */
+ SET_INFO(mvar,&FULL_MVAR_info);
+
/* ToDo: yield here for better communication performance? */
JMP_(ENTRY_CODE(Sp[0]));
FE_
ASSERT(CurrentTSO->why_blocked == NotBlocked);
CurrentTSO->why_blocked = BlockedOnRead;
CurrentTSO->block_info.fd = R1.i;
- PUSH_ON_BLOCKED_QUEUE(CurrentTSO);
+ ACQUIRE_LOCK(&sched_mutex);
+ APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
+ RELEASE_LOCK(&sched_mutex);
JMP_(stg_block_noregs);
FE_
}
ASSERT(CurrentTSO->why_blocked == NotBlocked);
CurrentTSO->why_blocked = BlockedOnWrite;
CurrentTSO->block_info.fd = R1.i;
- PUSH_ON_BLOCKED_QUEUE(CurrentTSO);
+ ACQUIRE_LOCK(&sched_mutex);
+ APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
+ RELEASE_LOCK(&sched_mutex);
JMP_(stg_block_noregs);
FE_
}
*/
CurrentTSO->block_info.delay = R1.i + ticks_since_select;
- PUSH_ON_BLOCKED_QUEUE(CurrentTSO);
+ ACQUIRE_LOCK(&sched_mutex);
+ APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
+ RELEASE_LOCK(&sched_mutex);
JMP_(stg_block_noregs);
FE_
}
/* -----------------------------------------------------------------------------
- * $Id: Profiling.c,v 1.9 1999/09/15 13:45:18 simonmar Exp $
+ * $Id: Profiling.c,v 1.10 1999/11/02 15:05:59 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
return ccs1;
}
- ASSERT(ccs2->prevStack != NULL);
- ccs = AppendCCS(ccs1, ccs2->prevStack);
+ if (ccs2->prevStack != NULL) {
+ ccs = AppendCCS(ccs1, ccs2->prevStack);
+ }
+
return PushCostCentre(ccs,ccs2->cc);
}
/* ----------------------------------------------------------------------------
- * $Id: RtsAPI.c,v 1.9 1999/10/15 11:03:10 sewardj Exp $
+ * $Id: RtsAPI.c,v 1.10 1999/11/02 15:05:59 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
rts_eval (HaskellObj p, /*out*/HaskellObj *ret)
{
StgTSO *tso = createGenThread(RtsFlags.GcFlags.initialStkSize, p);
- return schedule(tso, ret);
+ scheduleThread(tso);
+ return waitThread(tso, ret);
}
SchedulerStatus
rts_eval_ (HaskellObj p, unsigned int stack_size, /*out*/HaskellObj *ret)
{
StgTSO *tso = createGenThread(stack_size, p);
- return schedule(tso, ret);
+ scheduleThread(tso);
+ return waitThread(tso, ret);
}
/*
rts_evalIO (HaskellObj p, /*out*/HaskellObj *ret)
{
StgTSO* tso = createStrictIOThread(RtsFlags.GcFlags.initialStkSize, p);
- return schedule(tso, ret);
+ scheduleThread(tso);
+ return waitThread(tso, ret);
}
/*
rts_evalLazyIO (HaskellObj p, unsigned int stack_size, /*out*/HaskellObj *ret)
{
StgTSO *tso = createIOThread(stack_size, p);
- return schedule(tso, ret);
+ scheduleThread(tso);
+ return waitThread(tso, ret);
}
/* Convenience function for decoding the returned status. */
/* -----------------------------------------------------------------------------
- * $Id: RtsFlags.c,v 1.19 1999/09/15 13:45:19 simonmar Exp $
+ * $Id: RtsFlags.c,v 1.20 1999/11/02 15:06:00 simonmar Exp $
*
* (c) The AQUA Project, Glasgow University, 1994-1997
* (c) The GHC Team, 1998-1999
#endif
RtsFlags.ConcFlags.ctxtSwitchTime = CS_MIN_MILLISECS; /* In milliseconds */
+#ifdef SMP
+ RtsFlags.ConcFlags.nNodes = 1;
+#endif
#ifdef PAR
RtsFlags.ParFlags.parallelStats = rtsFalse;
RtsFlags.ParFlags.granSimStats = rtsFalse;
" -C<secs> Context-switch interval in seconds",
" (0 or no argument means switch as often as possible)",
" the default is .01 sec; resolution is .01 sec",
+# ifdef SMP
+" -N<n> Use <n> OS threads (default: 1)",
+# endif
# ifdef PAR
" -q Enable activity profile (output files in ~/<program>*.gr)",
" -qb Enable binary activity profile (output file /tmp/<program>.gb)",
}
break;
+#ifdef SMP
+ case 'N':
+ if (rts_argv[arg][2] != '\0') {
+ RtsFlags.ConcFlags.nNodes
+ = strtol(rts_argv[arg]+2, (char **) NULL, 10);
+ if (RtsFlags.ConcFlags.nNodes <= 0) {
+ fprintf(stderr, "setupRtsFlags: bad value for -N\n");
+ error = rtsTrue;
+ }
+ }
+ break;
+#endif
/* =========== PARALLEL =========================== */
case 'e':
PAR_BUILD_ONLY(
/* -----------------------------------------------------------------------------
- * $Id: RtsFlags.h,v 1.16 1999/09/15 13:45:19 simonmar Exp $
+ * $Id: RtsFlags.h,v 1.17 1999/11/02 15:06:00 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
#endif /* DEBUG || PROFILING */
struct CONCURRENT_FLAGS {
- int ctxtSwitchTime; /* in milliseconds */
+ int ctxtSwitchTime; /* in milliseconds */
+#ifdef SMP
+ nat nNodes; /* number of threads to run simultaneously */
+#endif
};
#ifdef PAR
/* -----------------------------------------------------------------------------
- * $Id: RtsStartup.c,v 1.21 1999/09/22 11:53:33 sof Exp $
+ * $Id: RtsStartup.c,v 1.22 1999/11/02 15:06:01 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
*/
#endif /* PAR */
+ /* initialise scheduler data structures (needs to be done before
+ * initStorage()).
+ */
+ initScheduler();
+
/* initialize the storage manager */
initStorage();
install_vtalrm_handler();
initialize_virtual_timer(TICK_MILLISECS);
- /* Initialise the scheduler */
- initScheduler();
+ /* start our haskell execution tasks */
+#ifdef SMP
+ startTasks();
+#endif
/* Initialise the stats department */
initStats();
end_gr_simulation();
#endif
+ /* stop all running tasks */
+ exitScheduler();
+
/* clean up things from the storage manager's point of view */
exitStorage();
/* -----------------------------------------------------------------------------
- * $Id: Schedule.c,v 1.27 1999/10/19 15:41:18 simonmar Exp $
+ * $Id: Schedule.c,v 1.28 1999/11/02 15:06:01 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
*
* ---------------------------------------------------------------------------*/
+/* Version with scheduler monitor support for SMPs.
+
+ This design provides a high-level API to create and schedule threads etc.
+ as documented in the SMP design document.
+
+ It uses a monitor design controlled by a single mutex to exercise control
+ over accesses to shared data structures, and builds on the Posix threads
+ library.
+
+ The majority of state is shared. In order to keep essential per-task state,
+ there is a Capability structure, which contains all the information
+ needed to run a thread: its STG registers, a pointer to its TSO, a
+ nursery etc. During STG execution, a pointer to the capability is
+ kept in a register (BaseReg).
+
+ In a non-SMP build, there is one global capability, namely MainRegTable.
+
+ SDM & KH, 10/99
+*/
+
#include "Rts.h"
#include "SchedAPI.h"
#include "RtsUtils.h"
#include "Signals.h"
#include "Profiling.h"
#include "Sanity.h"
+#include "Stats.h"
+/* Main threads:
+ *
+ * These are the threads which clients have requested that we run.
+ *
+ * In an SMP build, we might have several concurrent clients all
+ * waiting for results, and each one will wait on a condition variable
+ * until the result is available.
+ *
+ * In non-SMP, clients are strictly nested: the first client calls
+ * into the RTS, which might call out again to C with a _ccall_GC, and
+ * eventually re-enter the RTS.
+ *
+ * Main threads information is kept in a linked list:
+ */
+typedef struct StgMainThread_ {
+ StgTSO * tso;
+ SchedulerStatus stat;
+ StgClosure ** ret;
+#ifdef SMP
+ pthread_cond_t wakeup;
+#endif
+ struct StgMainThread_ *link;
+} StgMainThread;
+
+/* Main thread queue.
+ * Locks required: sched_mutex.
+ */
+static StgMainThread *main_threads;
+
+/* Thread queues.
+ * Locks required: sched_mutex.
+ */
StgTSO *run_queue_hd, *run_queue_tl;
StgTSO *blocked_queue_hd, *blocked_queue_tl;
-StgTSO *ccalling_threads;
-#define MAX_SCHEDULE_NESTING 256
-nat next_main_thread;
-StgTSO *main_threads[MAX_SCHEDULE_NESTING];
+/* Threads suspended in _ccall_GC.
+ * Locks required: sched_mutex.
+ */
+static StgTSO *suspended_ccalling_threads;
+
+#ifndef SMP
+static rtsBool in_ccall_gc;
+#endif
static void GetRoots(void);
static StgTSO *threadStackOverflow(StgTSO *tso);
+/* KH: The following two flags are shared memory locations. There is no need
+ to lock them, since they are only unset at the end of a scheduler
+ operation.
+*/
+
/* flag set by signal handler to precipitate a context switch */
nat context_switch;
/* if this flag is set as well, give up execution */
static nat interrupted;
-/* Next thread ID to allocate */
+/* Next thread ID to allocate.
+ * Locks required: sched_mutex
+ */
StgThreadID next_thread_id = 1;
/*
* Rule of thumb: if CurrentTSO != NULL, then we're running a Haskell
* thread. If CurrentTSO == NULL, then we're at the scheduler level.
*/
-StgTSO *CurrentTSO;
-StgRegTable MainRegTable;
-
-/*
- * The thread state for the main thread.
- */
-StgTSO *MainTSO;
-
+
/* The smallest stack size that makes any sense is:
* RESERVED_STACK_WORDS (so we can get back from the stack overflow)
* + sizeofW(StgStopFrame) (the stg_stop_thread_info frame)
#define MIN_STACK_WORDS (RESERVED_STACK_WORDS + sizeofW(StgStopFrame) + 2)
+/* Free capability list.
+ * Locks required: sched_mutex.
+ */
+#ifdef SMP
+Capability *free_capabilities; /* Available capabilities for running threads */
+nat n_free_capabilities; /* total number of available capabilities */
+#else
+Capability MainRegTable; /* for non-SMP, we have one global capability */
+#endif
+
+rtsBool ready_to_gc;
+
+/* All our current task ids, saved in case we need to kill them later.
+ */
+#ifdef SMP
+task_info *task_ids;
+#endif
+
+void addToBlockedQueue ( StgTSO *tso );
+
+static void schedule ( void );
+static void initThread ( StgTSO *tso, nat stack_size );
+static void interruptStgRts ( void );
+
+#ifdef SMP
+pthread_mutex_t sched_mutex = PTHREAD_MUTEX_INITIALIZER;
+pthread_mutex_t term_mutex = PTHREAD_MUTEX_INITIALIZER;
+pthread_cond_t thread_ready_cond = PTHREAD_COND_INITIALIZER;
+pthread_cond_t gc_pending_cond = PTHREAD_COND_INITIALIZER;
+
+nat await_death;
+#endif
+
+/* -----------------------------------------------------------------------------
+ Main scheduling loop.
+
+ We use round-robin scheduling, each thread returning to the
+ scheduler loop when one of these conditions is detected:
+
+ * out of heap space
+ * timer expires (thread yields)
+ * thread blocks
+ * thread ends
+ * stack overflow
+
+ Locking notes: we acquire the scheduler lock once at the beginning
+ of the scheduler loop, and release it when
+
+ * running a thread, or
+ * waiting for work, or
+ * waiting for a GC to complete.
+
+ -------------------------------------------------------------------------- */
+
+static void
+schedule( void )
+{
+ StgTSO *t;
+ Capability *cap;
+ StgThreadReturnCode ret;
+
+ ACQUIRE_LOCK(&sched_mutex);
+
+ while (1) {
+
+ /* Check whether any waiting threads need to be woken up.
+ * If the run queue is empty, we can wait indefinitely for
+ * something to happen.
+ */
+ if (blocked_queue_hd != END_TSO_QUEUE) {
+ awaitEvent(run_queue_hd == END_TSO_QUEUE);
+ }
+
+ /* check for signals each time around the scheduler */
+#ifndef __MINGW32__
+ if (signals_pending()) {
+ start_signal_handlers();
+ }
+#endif
+
+#ifdef SMP
+ /* If there's a GC pending, don't do anything until it has
+ * completed.
+ */
+ if (ready_to_gc) {
+ IF_DEBUG(scheduler,fprintf(stderr,"schedule (task %ld): waiting for GC\n",
+ pthread_self()););
+ pthread_cond_wait(&gc_pending_cond, &sched_mutex);
+ }
+
+ /* block until we've got a thread on the run queue and a free
+ * capability.
+ */
+ while (run_queue_hd == END_TSO_QUEUE || free_capabilities == NULL) {
+ IF_DEBUG(scheduler,
+ fprintf(stderr, "schedule (task %ld): waiting for work\n",
+ pthread_self()););
+ pthread_cond_wait(&thread_ready_cond, &sched_mutex);
+ IF_DEBUG(scheduler,
+ fprintf(stderr, "schedule (task %ld): work now available\n",
+ pthread_self()););
+ }
+#endif
+
+ /* grab a thread from the run queue
+ */
+ t = POP_RUN_QUEUE();
+
+ /* grab a capability
+ */
+#ifdef SMP
+ cap = free_capabilities;
+ free_capabilities = cap->link;
+ n_free_capabilities--;
+#else
+ cap = &MainRegTable;
+#endif
+
+ cap->rCurrentTSO = t;
+
+ /* set the context_switch flag
+ */
+ if (run_queue_hd == END_TSO_QUEUE)
+ context_switch = 0;
+ else
+ context_switch = 1;
+
+ RELEASE_LOCK(&sched_mutex);
+
+ /* Run the current thread
+ */
+ switch (cap->rCurrentTSO->whatNext) {
+ case ThreadKilled:
+ case ThreadComplete:
+ /* Thread already finished, return to scheduler. */
+ ret = ThreadFinished;
+ break;
+ case ThreadEnterGHC:
+ ret = StgRun((StgFunPtr) stg_enterStackTop, cap);
+ break;
+ case ThreadRunGHC:
+ ret = StgRun((StgFunPtr) stg_returnToStackTop, cap);
+ break;
+ case ThreadEnterHugs:
+#ifdef INTERPRETER
+ {
+ IF_DEBUG(scheduler,belch("schedule: entering Hugs"));
+ LoadThreadState();
+ /* CHECK_SENSIBLE_REGS(); */
+ {
+ StgClosure* c = (StgClosure *)Sp[0];
+ Sp += 1;
+ ret = enter(c);
+ }
+ SaveThreadState();
+ break;
+ }
+#else
+ barf("Panic: entered a BCO but no bytecode interpreter in this build");
+#endif
+ default:
+ barf("schedule: invalid whatNext field");
+ }
+
+ /* Costs for the scheduler are assigned to CCS_SYSTEM */
+#ifdef PROFILING
+ CCCS = CCS_SYSTEM;
+#endif
+
+ ACQUIRE_LOCK(&sched_mutex);
+
+#ifdef SMP
+ IF_DEBUG(scheduler,fprintf(stderr,"schedule (task %ld): ", pthread_self()););
+#else
+ IF_DEBUG(scheduler,fprintf(stderr,"schedule: "););
+#endif
+ t = cap->rCurrentTSO;
+
+ switch (ret) {
+ case HeapOverflow:
+ /* make all the running tasks block on a condition variable,
+ * maybe set context_switch and wait till they all pile in,
+ * then have them wait on a GC condition variable.
+ */
+ IF_DEBUG(scheduler,belch("thread %ld stopped: HeapOverflow", t->id));
+ threadPaused(t);
+
+ ready_to_gc = rtsTrue;
+ context_switch = 1; /* stop other threads ASAP */
+ PUSH_ON_RUN_QUEUE(t);
+ break;
+
+ case StackOverflow:
+ /* just adjust the stack for this thread, then pop it back
+ * on the run queue.
+ */
+ IF_DEBUG(scheduler,belch("thread %ld stopped, StackOverflow", t->id));
+ threadPaused(t);
+ {
+ StgMainThread *m;
+ /* enlarge the stack */
+ StgTSO *new_t = threadStackOverflow(t);
+
+ /* This TSO has moved, so update any pointers to it from the
+ * main thread stack. It better not be on any other queues...
+ * (it shouldn't be)
+ */
+ for (m = main_threads; m != NULL; m = m->link) {
+ if (m->tso == t) {
+ m->tso = new_t;
+ }
+ }
+ PUSH_ON_RUN_QUEUE(new_t);
+ }
+ break;
+
+ case ThreadYielding:
+ /* put the thread back on the run queue. Then, if we're ready to
+ * GC, check whether this is the last task to stop. If so, wake
+ * up the GC thread. getThread will block during a GC until the
+ * GC is finished.
+ */
+ IF_DEBUG(scheduler,
+ if (t->whatNext == ThreadEnterHugs) {
+ /* ToDo: or maybe a timer expired when we were in Hugs?
+ * or maybe someone hit ctrl-C
+ */
+ belch("thread %ld stopped to switch to Hugs", t->id);
+ } else {
+ belch("thread %ld stopped, yielding", t->id);
+ }
+ );
+ threadPaused(t);
+ APPEND_TO_RUN_QUEUE(t);
+ break;
+
+ case ThreadBlocked:
+ /* don't need to do anything. Either the thread is blocked on
+ * I/O, in which case we'll have called addToBlockedQueue
+ * previously, or it's blocked on an MVar or Blackhole, in which
+ * case it'll be on the relevant queue already.
+ */
+ IF_DEBUG(scheduler,
+ fprintf(stderr, "thread %d stopped, ", t->id);
+ printThreadBlockage(t);
+ fprintf(stderr, "\n"));
+ threadPaused(t);
+ break;
+
+ case ThreadFinished:
+ /* Need to check whether this was a main thread, and if so, signal
+ * the task that started it with the return value. If we have no
+ * more main threads, we probably need to stop all the tasks until
+ * we get a new one.
+ */
+ IF_DEBUG(scheduler,belch("thread %ld finished", t->id));
+ t->whatNext = ThreadComplete;
+ break;
+
+ default:
+ barf("doneThread: invalid thread return code");
+ }
+
+#ifdef SMP
+ cap->link = free_capabilities;
+ free_capabilities = cap;
+ n_free_capabilities++;
+#endif
+
+#ifdef SMP
+ if (ready_to_gc && n_free_capabilities == RtsFlags.ConcFlags.nNodes) {
+#else
+ if (ready_to_gc) {
+#endif
+ /* everybody back, start the GC.
+ * Could do it in this thread, or signal a condition var
+ * to do it in another thread. Either way, we need to
+ * broadcast on gc_pending_cond afterward.
+ */
+#ifdef SMP
+ IF_DEBUG(scheduler,belch("schedule (task %ld): doing GC", pthread_self()));
+#endif
+ GarbageCollect(GetRoots);
+ ready_to_gc = rtsFalse;
+#ifdef SMP
+ pthread_cond_broadcast(&gc_pending_cond);
+#endif
+ }
+
+ /* Go through the list of main threads and wake up any
+ * clients whose computations have finished. ToDo: this
+ * should be done more efficiently without a linear scan
+ * of the main threads list, somehow...
+ */
+#ifdef SMP
+ {
+ StgMainThread *m, **prev;
+ prev = &main_threads;
+ for (m = main_threads; m != NULL; m = m->link) {
+ if (m->tso->whatNext == ThreadComplete) {
+ if (m->ret) {
+ *(m->ret) = (StgClosure *)m->tso->sp[0];
+ }
+ *prev = m->link;
+ m->stat = Success;
+ pthread_cond_broadcast(&m->wakeup);
+ }
+ if (m->tso->whatNext == ThreadKilled) {
+ *prev = m->link;
+ m->stat = Killed;
+ pthread_cond_broadcast(&m->wakeup);
+ }
+ }
+ }
+#else
+ /* If our main thread has finished or been killed, return.
+ * If we were re-entered as a result of a _ccall_gc, then
+ * pop the blocked thread off the ccalling_threads stack back
+ * into CurrentTSO.
+ */
+ {
+ StgMainThread *m = main_threads;
+ if (m->tso->whatNext == ThreadComplete
+ || m->tso->whatNext == ThreadKilled) {
+ main_threads = main_threads->link;
+ if (m->tso->whatNext == ThreadComplete) {
+ /* we finished successfully, fill in the return value */
+ if (m->ret) { *(m->ret) = (StgClosure *)m->tso->sp[0]; };
+ m->stat = Success;
+ return;
+ } else {
+ m->stat = Killed;
+ return;
+ }
+ }
+ }
+#endif
+
+ } /* end of while(1) */
+}
+
+/* -----------------------------------------------------------------------------
+ * Suspending & resuming Haskell threads.
+ *
+ * When making a "safe" call to C (aka _ccall_GC), the task gives back
+ * its capability before calling the C function. This allows another
+ * task to pick up the capability and carry on running Haskell
+ * threads. It also means that if the C call blocks, it won't lock
+ * the whole system.
+ *
+ * The Haskell thread making the C call is put to sleep for the
+ * duration of the call, on the susepended_ccalling_threads queue. We
+ * give out a token to the task, which it can use to resume the thread
+ * on return from the C function.
+ * -------------------------------------------------------------------------- */
+
+StgInt
+suspendThread( Capability *cap )
+{
+ nat tok;
+
+ ACQUIRE_LOCK(&sched_mutex);
+
+#ifdef SMP
+ IF_DEBUG(scheduler,
+ fprintf(stderr, "schedule (task %ld): thread %d did a _ccall_gc\n",
+ pthread_self(), cap->rCurrentTSO->id));
+#else
+ IF_DEBUG(scheduler,
+ fprintf(stderr, "schedule: thread %d did a _ccall_gc\n",
+ cap->rCurrentTSO->id));
+#endif
+
+ threadPaused(cap->rCurrentTSO);
+ cap->rCurrentTSO->link = suspended_ccalling_threads;
+ suspended_ccalling_threads = cap->rCurrentTSO;
+
+ /* Use the thread ID as the token; it should be unique */
+ tok = cap->rCurrentTSO->id;
+
+#ifdef SMP
+ cap->link = free_capabilities;
+ free_capabilities = cap;
+ n_free_capabilities++;
+#endif
+
+ RELEASE_LOCK(&sched_mutex);
+ return tok;
+}
+
+Capability *
+resumeThread( StgInt tok )
+{
+ StgTSO *tso, **prev;
+ Capability *cap;
+
+ ACQUIRE_LOCK(&sched_mutex);
+
+ prev = &suspended_ccalling_threads;
+ for (tso = suspended_ccalling_threads;
+ tso != END_TSO_QUEUE;
+ prev = &tso->link, tso = tso->link) {
+ if (tso->id == (StgThreadID)tok) {
+ *prev = tso->link;
+ break;
+ }
+ }
+ if (tso == END_TSO_QUEUE) {
+ barf("resumeThread: thread not found");
+ }
+
+#ifdef SMP
+ while (free_capabilities == NULL) {
+ IF_DEBUG(scheduler,
+ fprintf(stderr,"schedule (task %ld): waiting to resume\n",
+ pthread_self()));
+ pthread_cond_wait(&thread_ready_cond, &sched_mutex);
+ IF_DEBUG(scheduler,fprintf(stderr,
+ "schedule (task %ld): resuming thread %d\n",
+ pthread_self(), tso->id));
+ }
+ cap = free_capabilities;
+ free_capabilities = cap->link;
+ n_free_capabilities--;
+#else
+ cap = &MainRegTable;
+#endif
+
+ cap->rCurrentTSO = tso;
+
+ RELEASE_LOCK(&sched_mutex);
+ return cap;
+}
+
/* -----------------------------------------------------------------------------
* Static functions
* -------------------------------------------------------------------------- */
{
SET_INFO(tso,&TSO_info);
tso->whatNext = ThreadEnterGHC;
- tso->id = next_thread_id++;
+
+ /* tso->id needs to be unique. For now we use a heavyweight mutex to
+ protect the increment operation on next_thread_id.
+ In future, we could use an atomic increment instead.
+ */
+
+ ACQUIRE_LOCK(&sched_mutex);
+ tso->id = next_thread_id++;
+ RELEASE_LOCK(&sched_mutex);
+
tso->why_blocked = NotBlocked;
tso->splim = (P_)&(tso->stack) + RESERVED_STACK_WORDS;
SET_HDR((StgClosure*)tso->sp,(StgInfoTable *)&stg_stop_thread_info,CCS_MAIN);
tso->su = (StgUpdateFrame*)tso->sp;
- IF_DEBUG(scheduler,belch("Initialised thread %ld, stack size = %lx words\n",
+ IF_DEBUG(scheduler,belch("schedule: Initialised thread %ld, stack size = %lx words",
tso->id, tso->stack_size));
- /* Put the new thread on the head of the runnable queue.
- * The caller of createThread better push an appropriate closure
- * on this thread's stack before the scheduler is invoked.
+}
+
+
+/* -----------------------------------------------------------------------------
+ * scheduleThread()
+ *
+ * scheduleThread puts a thread on the head of the runnable queue.
+ * This will usually be done immediately after a thread is created.
+ * The caller of scheduleThread must create the thread using e.g.
+ * createThread and push an appropriate closure
+ * on this thread's stack before the scheduler is invoked.
+ * -------------------------------------------------------------------------- */
+
+void
+scheduleThread(StgTSO *tso)
+{
+ ACQUIRE_LOCK(&sched_mutex);
+
+ /* Put the new thread on the head of the runnable queue. The caller
+ * better push an appropriate closure on this thread's stack
+ * beforehand. In the SMP case, the thread may start running as
+ * soon as we release the scheduler lock below.
*/
- tso->link = run_queue_hd;
- run_queue_hd = tso;
- if (run_queue_tl == END_TSO_QUEUE) {
- run_queue_tl = tso;
- }
+ PUSH_ON_RUN_QUEUE(tso);
+ THREAD_RUNNABLE();
IF_DEBUG(scheduler,printTSO(tso));
+ RELEASE_LOCK(&sched_mutex);
}
+
+/* -----------------------------------------------------------------------------
+ * startTasks()
+ *
+ * Start up Posix threads to run each of the scheduler tasks.
+ * I believe the task ids are not needed in the system as defined.
+ * KH @ 25/10/99
+ * -------------------------------------------------------------------------- */
+
+#ifdef SMP
+static void *
+taskStart( void *arg STG_UNUSED )
+{
+ schedule();
+ return NULL;
+}
+#endif
+
/* -----------------------------------------------------------------------------
* initScheduler()
*
* Initialise the scheduler. This resets all the queues - if the
* queues contained any threads, they'll be garbage collected at the
* next pass.
+ *
+ * This now calls startTasks(), so should only be called once! KH @ 25/10/99
* -------------------------------------------------------------------------- */
+#ifdef SMP
+static void
+term_handler(int sig STG_UNUSED)
+{
+ nat i;
+ pthread_t me = pthread_self();
+
+ for (i = 0; i < RtsFlags.ConcFlags.nNodes; i++) {
+ if (task_ids[i].id == me) {
+ task_ids[i].mut_time = usertime() - task_ids[i].gc_time;
+ if (task_ids[i].mut_time < 0.0) {
+ task_ids[i].mut_time = 0.0;
+ }
+ }
+ }
+ ACQUIRE_LOCK(&term_mutex);
+ await_death--;
+ RELEASE_LOCK(&term_mutex);
+ pthread_exit(NULL);
+}
+#endif
+
void initScheduler(void)
{
run_queue_hd = END_TSO_QUEUE;
run_queue_tl = END_TSO_QUEUE;
blocked_queue_hd = END_TSO_QUEUE;
blocked_queue_tl = END_TSO_QUEUE;
- ccalling_threads = END_TSO_QUEUE;
- next_main_thread = 0;
+
+ suspended_ccalling_threads = END_TSO_QUEUE;
+
+ main_threads = NULL;
context_switch = 0;
interrupted = 0;
enteredCAFs = END_CAF_LIST;
+
+ /* Install the SIGHUP handler */
+#ifdef SMP
+ {
+ struct sigaction action,oact;
+
+ action.sa_handler = term_handler;
+ sigemptyset(&action.sa_mask);
+ action.sa_flags = 0;
+ if (sigaction(SIGTERM, &action, &oact) != 0) {
+ barf("can't install TERM handler");
+ }
+ }
+#endif
+
+#ifdef SMP
+ /* Allocate N Capabilities */
+ {
+ nat i;
+ Capability *cap, *prev;
+ cap = NULL;
+ prev = NULL;
+ for (i = 0; i < RtsFlags.ConcFlags.nNodes; i++) {
+ cap = stgMallocBytes(sizeof(Capability), "initScheduler:capabilities");
+ cap->link = prev;
+ prev = cap;
+ }
+ free_capabilities = cap;
+ n_free_capabilities = RtsFlags.ConcFlags.nNodes;
+ }
+ IF_DEBUG(scheduler,fprintf(stderr,"schedule: Allocated %d capabilities\n",
+ n_free_capabilities););
+#endif
}
-/* -----------------------------------------------------------------------------
- Main scheduling loop.
+#ifdef SMP
+void
+startTasks( void )
+{
+ nat i;
+ int r;
+ pthread_t tid;
+
+ /* make some space for saving all the thread ids */
+ task_ids = stgMallocBytes(RtsFlags.ConcFlags.nNodes * sizeof(task_info),
+ "initScheduler:task_ids");
+
+ /* and create all the threads */
+ for (i = 0; i < RtsFlags.ConcFlags.nNodes; i++) {
+ r = pthread_create(&tid,NULL,taskStart,NULL);
+ if (r != 0) {
+ barf("startTasks: Can't create new Posix thread");
+ }
+ task_ids[i].id = tid;
+ IF_DEBUG(scheduler,fprintf(stderr,"schedule: Started task: %ld\n",tid););
+ }
+}
+#endif
- We use round-robin scheduling, each thread returning to the
- scheduler loop when one of these conditions is detected:
+void
+exitScheduler( void )
+{
+#ifdef SMP
+ nat i;
- * stack overflow
- * out of heap space
- * timer expires (thread yields)
- * thread blocks
- * thread ends
+ /* Don't want to use pthread_cancel, since we'd have to install
+ * these silly exception handlers (pthread_cleanup_{push,pop}) around
+ * all our locks.
+ */
+#if 0
+ /* Cancel all our tasks */
+ for (i = 0; i < RtsFlags.ConcFlags.nNodes; i++) {
+ pthread_cancel(task_ids[i].id);
+ }
+
+ /* Wait for all the tasks to terminate */
+ for (i = 0; i < RtsFlags.ConcFlags.nNodes; i++) {
+ IF_DEBUG(scheduler,fprintf(stderr,"schedule: waiting for task %ld\n",
+ task_ids[i].id));
+ pthread_join(task_ids[i].id, NULL);
+ }
+#endif
+
+ /* Send 'em all a SIGHUP. That should shut 'em up.
+ */
+ await_death = RtsFlags.ConcFlags.nNodes;
+ for (i = 0; i < RtsFlags.ConcFlags.nNodes; i++) {
+ pthread_kill(task_ids[i].id,SIGTERM);
+ }
+ while (await_death > 0) {
+ sched_yield();
+ }
+#endif
+}
+
+/* -----------------------------------------------------------------------------
+ Managing the per-task allocation areas.
+
+ Each capability comes with an allocation area. These are
+ fixed-length block lists into which allocation can be done.
+
+ ToDo: no support for two-space collection at the moment???
-------------------------------------------------------------------------- */
+/* -----------------------------------------------------------------------------
+ * waitThread is the external interface for running a new computataion
+ * and waiting for the result.
+ *
+ * In the non-SMP case, we create a new main thread, push it on the
+ * main-thread stack, and invoke the scheduler to run it. The
+ * scheduler will return when the top main thread on the stack has
+ * completed or died, and fill in the necessary fields of the
+ * main_thread structure.
+ *
+ * In the SMP case, we create a main thread as before, but we then
+ * create a new condition variable and sleep on it. When our new
+ * main thread has completed, we'll be woken up and the status/result
+ * will be in the main_thread struct.
+ * -------------------------------------------------------------------------- */
+
+SchedulerStatus
+waitThread(StgTSO *tso, /*out*/StgClosure **ret)
+{
+ StgMainThread *m;
+ SchedulerStatus stat;
+
+ ACQUIRE_LOCK(&sched_mutex);
+
+ m = stgMallocBytes(sizeof(StgMainThread), "waitThread");
+
+ m->tso = tso;
+ m->ret = ret;
+ m->stat = NoStatus;
+#ifdef SMP
+ pthread_cond_init(&m->wakeup, NULL);
+#endif
+
+ m->link = main_threads;
+ main_threads = m;
+
+#ifdef SMP
+ pthread_cond_wait(&m->wakeup, &sched_mutex);
+#else
+ schedule();
+#endif
+
+ stat = m->stat;
+ ASSERT(stat != NoStatus);
+
+#ifdef SMP
+ pthread_cond_destroy(&m->wakeup);
+#endif
+ free(m);
+
+ RELEASE_LOCK(&sched_mutex);
+ return stat;
+}
+
+
+#if 0
SchedulerStatus schedule(StgTSO *main, StgClosure **ret_val)
{
StgTSO *t;
/* Take a thread from the run queue.
*/
- t = run_queue_hd;
- if (t != END_TSO_QUEUE) {
- run_queue_hd = t->link;
- t->link = END_TSO_QUEUE;
- if (run_queue_hd == END_TSO_QUEUE) {
- run_queue_tl = END_TSO_QUEUE;
- }
- }
+ t = POP_RUN_QUEUE();
while (t != END_TSO_QUEUE) {
CurrentTSO = t;
/* Put the thread back on the run queue, at the end.
* t->link is already set to END_TSO_QUEUE.
*/
- PUSH_ON_RUN_QUEUE(t);
+ APPEND_TO_RUN_QUEUE(t);
break;
case ThreadBlocked:
break;
case ThreadFinished:
- IF_DEBUG(scheduler,belch("Thread %ld finished\n", t->id));
+ IF_DEBUG(scheduler,fprintf(stderr,"thread %ld finished\n", t->id));
t->whatNext = ThreadComplete;
break;
awaitEvent(run_queue_hd == END_TSO_QUEUE);
}
- t = run_queue_hd;
- if (t != END_TSO_QUEUE) {
- run_queue_hd = t->link;
- t->link = END_TSO_QUEUE;
- if (run_queue_hd == END_TSO_QUEUE) {
- run_queue_tl = END_TSO_QUEUE;
- }
- }
+ t = POP_RUN_QUEUE();
}
/* If we got to here, then we ran out of threads to run, but the
*/
return Deadlock;
}
+#endif
/* -----------------------------------------------------------------------------
Debugging: why is a thread blocked
-------------------------------------------------------------------------- */
+/* This has to be protected either by the scheduler monitor, or by the
+ garbage collection monitor (probably the latter).
+ KH @ 25/10/99
+*/
+
static void GetRoots(void)
{
- nat i;
+ StgMainThread *m;
run_queue_hd = (StgTSO *)MarkRoot((StgClosure *)run_queue_hd);
run_queue_tl = (StgTSO *)MarkRoot((StgClosure *)run_queue_tl);
blocked_queue_hd = (StgTSO *)MarkRoot((StgClosure *)blocked_queue_hd);
blocked_queue_tl = (StgTSO *)MarkRoot((StgClosure *)blocked_queue_tl);
- ccalling_threads = (StgTSO *)MarkRoot((StgClosure *)ccalling_threads);
-
- for (i = 0; i < next_main_thread; i++) {
- main_threads[i] = (StgTSO *)MarkRoot((StgClosure *)main_threads[i]);
+ for (m = main_threads; m != NULL; m = m->link) {
+ m->tso = (StgTSO *)MarkRoot((StgClosure *)m->tso);
}
+ suspended_ccalling_threads =
+ (StgTSO *)MarkRoot((StgClosure *)suspended_ccalling_threads);
}
/* -----------------------------------------------------------------------------
It might be useful to provide an interface whereby the programmer
can specify more roots (ToDo).
+
+ This needs to be protected by the GC condition variable above. KH.
-------------------------------------------------------------------------- */
void (*extra_roots)(void);
new_tso_size = round_to_mblocks(new_tso_size); /* Be MBLOCK-friendly */
new_stack_size = new_tso_size - TSO_STRUCT_SIZEW;
- IF_DEBUG(scheduler, fprintf(stderr,"increasing stack size from %d words to %d.\n", tso->stack_size, new_stack_size));
+ IF_DEBUG(scheduler, fprintf(stderr,"schedule: increasing stack size from %d words to %d.\n", tso->stack_size, new_stack_size));
dest = (StgTSO *)allocate(new_tso_size);
TICK_ALLOC_TSO(new_tso_size-sizeofW(StgTSO),0);
#if 0
IF_DEBUG(scheduler,printTSO(dest));
#endif
+
+#if 0
+ /* This will no longer work: KH */
if (tso == MainTSO) { /* hack */
MainTSO = dest;
}
+#endif
return dest;
}
Wake up a queue that was blocked on some resource.
-------------------------------------------------------------------------- */
-StgTSO *unblockOne(StgTSO *tso)
+static StgTSO *
+unblockOneLocked(StgTSO *tso)
{
StgTSO *next;
ASSERT(tso->why_blocked != NotBlocked);
tso->why_blocked = NotBlocked;
next = tso->link;
- tso->link = END_TSO_QUEUE;
PUSH_ON_RUN_QUEUE(tso);
- IF_DEBUG(scheduler,belch("Waking up thread %ld", tso->id));
+ THREAD_RUNNABLE();
+#ifdef SMP
+ IF_DEBUG(scheduler,belch("schedule (task %ld): waking up thread %ld",
+ pthread_self(), tso->id));
+#else
+ IF_DEBUG(scheduler,belch("schedule: waking up thread %ld", tso->id));
+#endif
return next;
}
-void awakenBlockedQueue(StgTSO *tso)
+inline StgTSO *
+unblockOne(StgTSO *tso)
{
+ ACQUIRE_LOCK(&sched_mutex);
+ tso = unblockOneLocked(tso);
+ RELEASE_LOCK(&sched_mutex);
+ return tso;
+}
+
+void
+awakenBlockedQueue(StgTSO *tso)
+{
+ ACQUIRE_LOCK(&sched_mutex);
while (tso != END_TSO_QUEUE) {
- tso = unblockOne(tso);
+ tso = unblockOneLocked(tso);
}
+ RELEASE_LOCK(&sched_mutex);
}
/* -----------------------------------------------------------------------------
{
StgTSO *t, **last;
+ ACQUIRE_LOCK(&sched_mutex);
switch (tso->why_blocked) {
case NotBlocked:
tso->why_blocked = NotBlocked;
tso->block_info.closure = NULL;
PUSH_ON_RUN_QUEUE(tso);
+ RELEASE_LOCK(&sched_mutex);
}
/* -----------------------------------------------------------------------------
return;
}
- IF_DEBUG(scheduler, belch("Raising exception in thread %ld.", tso->id));
+ IF_DEBUG(scheduler, belch("schedule: Raising exception in thread %ld.", tso->id));
/* Remove it from any blocking queues */
unblockThread(tso);
TICK_ALLOC_UP_THK(words+1,0);
IF_DEBUG(scheduler,
- fprintf(stderr, "Updating ");
+ fprintf(stderr, "schedule: Updating ");
printPtr((P_)su->updatee);
fprintf(stderr, " with ");
printObj((StgClosure *)ap);
o->payload[1] = cf->handler;
IF_DEBUG(scheduler,
- fprintf(stderr, "Built ");
+ fprintf(stderr, "schedule: Built ");
printObj((StgClosure *)o);
);
payloadCPtr(o,0) = (StgClosure *)ap;
IF_DEBUG(scheduler,
- fprintf(stderr, "Built ");
+ fprintf(stderr, "schedule: Built ");
printObj((StgClosure *)o);
);
}
barf("raiseAsync");
}
+
/* -----------------------------------------------------------------------------
- * $Id: Schedule.h,v 1.8 1999/10/19 15:39:08 simonmar Exp $
+ * $Id: Schedule.h,v 1.9 1999/11/02 15:06:02 simonmar Exp $
*
* (c) The GHC Team 1998-1999
*
*
* ---------------------------------------------------------------------------*/
-/*
- * Initialisation
+/* initScheduler(), exitScheduler(), startTasks()
+ *
+ * Called from STG : no
+ * Locks assumed : none
*/
+void initScheduler( void );
+void exitScheduler( void );
+#ifdef SMP
+void startTasks( void );
+#endif
-void initScheduler(void);
-
-/*
- * Miscellany
+/* awakenBlockedQueue()
+ *
+ * Takes a pointer to the beginning of a blocked TSO queue, and
+ * wakes up the entire queue.
+ *
+ * Called from STG : yes
+ * Locks assumed : none
*/
+void awakenBlockedQueue(StgTSO *tso);
-void awakenBlockedQueue(StgTSO *tso);
+/* unblockOne()
+ *
+ * Takes a pointer to the beginning of a blocked TSO queue, and
+ * removes the first thread, placing it on the runnable queue.
+ *
+ * Called from STG : yes
+ * Locks assumed : none
+ */
StgTSO *unblockOne(StgTSO *tso);
-void initThread(StgTSO *tso, nat stack_size);
-void interruptStgRts(void);
-void raiseAsync(StgTSO *tso, StgClosure *exception);
-extern nat context_switch;
+/* raiseAsync()
+ *
+ * Raises an exception asynchronously in the specified thread.
+ *
+ * Called from STG : yes
+ * Locks assumed : none
+ */
+void raiseAsync(StgTSO *tso, StgClosure *exception);
+
+/* awaitEvent()
+ *
+ * Raises an exception asynchronously in the specified thread.
+ *
+ * Called from STG : NO
+ * Locks assumed : sched_mutex
+ */
+void awaitEvent(rtsBool wait); /* In Select.c */
+
+/* Context switch flag.
+ * Locks required : sched_mutex
+ */
+extern nat context_switch;
+
+extern nat ticks_since_select;
-void awaitEvent(rtsBool wait); /* In Select.c */
-extern nat ticks_since_select; /* ditto */
+/* Capability type
+ */
+typedef StgRegTable Capability;
+
+/* Free capability list.
+ * Locks required: sched_mutex.
+ */
+#ifdef SMP
+extern Capability *free_capabilities;
+extern nat n_free_capabilities;
+#else
+extern Capability MainRegTable;
+#endif
+/* Thread queues.
+ * Locks required : sched_mutex
+ */
extern StgTSO *run_queue_hd, *run_queue_tl;
extern StgTSO *blocked_queue_hd, *blocked_queue_tl;
extern void printThreadBlockage(StgTSO *tso);
#endif
-#ifdef COMPILING_RTS_MAIN
-extern DLLIMPORT StgTSO *MainTSO; /* temporary hack */
-#else
-extern StgTSO *MainTSO; /* temporary hack */
+#ifdef SMP
+extern pthread_mutex_t sched_mutex;
+extern pthread_cond_t thread_ready_cond;
+extern pthread_cond_t gc_pending_cond;
+#endif
+
+#ifdef SMP
+typedef struct {
+ pthread_t id;
+ double mut_time;
+ double gc_time;
+ double gc_etime;
+} task_info;
+
+extern task_info *task_ids;
#endif
+
+/* -----------------------------------------------------------------------------
+ * Some convenient macros...
+ */
+
#define END_TSO_QUEUE ((StgTSO *)(void*)&END_TSO_QUEUE_closure)
+#define END_CAF_LIST ((StgCAF *)(void*)&END_TSO_QUEUE_closure)
/* Add a thread to the end of the run queue.
* NOTE: tso->link should be END_TSO_QUEUE before calling this macro.
*/
-#define PUSH_ON_RUN_QUEUE(tso) \
+#define APPEND_TO_RUN_QUEUE(tso) \
ASSERT(tso->link == END_TSO_QUEUE); \
if (run_queue_hd == END_TSO_QUEUE) { \
run_queue_hd = tso; \
} \
run_queue_tl = tso;
-#define PUSH_ON_BLOCKED_QUEUE(tso) \
+/* Push a thread on the beginning of the run queue. Used for
+ * newly awakened threads, so they get run as soon as possible.
+ */
+#define PUSH_ON_RUN_QUEUE(tso) \
+ tso->link = run_queue_hd; \
+ run_queue_hd = tso; \
+ if (run_queue_tl == END_TSO_QUEUE) { \
+ run_queue_tl = tso; \
+ }
+
+/* Pop the first thread off the runnable queue.
+ */
+#define POP_RUN_QUEUE() \
+ ({ StgTSO *t = run_queue_hd; \
+ if (t != END_TSO_QUEUE) { \
+ run_queue_hd = t->link; \
+ t->link = END_TSO_QUEUE; \
+ if (run_queue_hd == END_TSO_QUEUE) { \
+ run_queue_tl = END_TSO_QUEUE; \
+ } \
+ } \
+ t; \
+ })
+
+/* Add a thread to the end of the blocked queue.
+ */
+#define APPEND_TO_BLOCKED_QUEUE(tso) \
ASSERT(tso->link == END_TSO_QUEUE); \
if (blocked_queue_hd == END_TSO_QUEUE) { \
blocked_queue_hd = tso; \
} \
blocked_queue_tl = tso;
-#define END_CAF_LIST stgCast(StgCAF*,(void*)&END_TSO_QUEUE_closure)
+/* Signal that a runnable thread has become available, in
+ * case there are any waiting tasks to execute it.
+ */
+#ifdef SMP
+#define THREAD_RUNNABLE() \
+ if (free_capabilities != NULL) { \
+ pthread_cond_signal(&thread_ready_cond); \
+ } \
+ context_switch = 1;
+#else
+#define THREAD_RUNNABLE() /* nothing */
+#endif
+
/* -----------------------------------------------------------------------------
- * $Id: Signals.c,v 1.8 1999/09/22 11:53:33 sof Exp $
+ * $Id: Signals.c,v 1.9 1999/11/02 15:06:02 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
}
#endif
+/* -----------------------------------------------------------------------------
+ SIGINT handler.
+
+ We like to shutdown nicely after receiving a SIGINT, write out the
+ stats, write profiling info, close open files and flush buffers etc.
+ -------------------------------------------------------------------------- */
+
+#ifdef SMP
+pthread_t startup_guy;
+#endif
+
static void
shutdown_handler(int sig)
{
+#ifdef SMP
+ /* if I'm a worker thread, send this signal to the guy who
+ * originally called startupHaskell(). Since we're handling
+ * the signal, it won't be a "send to all threads" type of signal
+ * (according to the POSIX threads spec).
+ */
+ if (pthread_self() != startup_guy) {
+ pthread_kill(startup_guy, sig);
+ } else
+#endif
+
shutdownHaskellAndExit(EXIT_FAILURE);
}
/*
* The RTS installs a default signal handler for catching
- * SIGINT, so that we can perform an orderly shutdown (finalising
- * objects and flushing buffers etc.)
+ * SIGINT, so that we can perform an orderly shutdown.
*
* Haskell code may install their own SIGINT handler, which is
* fine, provided they're so kind as to put back the old one
{
struct sigaction action,oact;
+#ifdef SMP
+ startup_guy = pthread_self();
+#endif
action.sa_handler = shutdown_handler;
sigemptyset(&action.sa_mask);
action.sa_flags = 0;
/* -----------------------------------------------------------------------------
- * $Id: Stats.c,v 1.14 1999/09/15 13:45:20 simonmar Exp $
+ * $Id: Stats.c,v 1.15 1999/11/02 15:06:03 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
#include "RtsUtils.h"
#include "StoragePriv.h"
#include "MBlock.h"
-
-/**
- * Ian: For the moment we just want to ignore
- * these on Nemesis
- **/
-#ifdef _NEMESIS_OS_
-#ifdef HAVE_SYS_TIMES_H
-#undef HAVE_SYS_TIMES_H /* <sys/times.h> */
-#endif
-#ifdef HAVE_SYS_RESOURCE_H /* <sys/resource.h> */
-#undef HAVE_SYS_RESOURCE_H
-#endif
-#ifdef HAVE_SYS_TIME_H /* <sys/time.h> */
-#undef HAVE_SYS_TIME_H
-#endif
-#ifdef HAVE_SYS_TIMEB_H
-#undef HAVE_SYS_TIMEB_H /* <sys/timeb.h> */
-#endif
-#ifdef HAVE_UNISTD_H
-#undef HAVE_UNISTD_H /* <unistd.h> */
-#endif
-#ifdef HAVE_TIMES
-#undef HAVE_TIMES
-#endif
-#ifdef HAVE_FTIME
-#undef HAVE_FTIME
-#endif
-#ifdef HAVE_GETRUSAGE
-#undef HAVE_GETRUSAGE
-#endif
-#ifdef HAVE_SYSCONF
-#undef HAVE_SYSCONF
-#endif
-#endif /* _NEMESIS_OS_ */
-
+#include "Schedule.h"
#include "Stats.h"
#ifdef HAVE_UNISTD_H
FILE *sf = RtsFlags.GcFlags.statsFile;
if (sf != NULL) {
- double time = usertime();
- double etime = elapsedtime();
+ double time = usertime();
+ double etime = elapsedtime();
+ double gc_time = time-GC_start_time;
+ double gc_etime = etime-GCe_start_time;
if (RtsFlags.GcFlags.giveStats >= VERBOSE_GC_STATS) {
nat faults = pagefaults();
fprintf(sf, "%9ld %9ld %9ld",
alloc*sizeof(W_), collect*sizeof(W_), live*sizeof(W_));
fprintf(sf, " %5.2f %5.2f %7.2f %7.2f %4ld %4ld (Gen: %2ld)\n",
- (time-GC_start_time),
- (etime-GCe_start_time),
+ gc_time,
+ gc_etime,
time,
etime,
faults - GC_start_faults,
GC_tot_time += time-GC_start_time;
GCe_tot_time += etime-GCe_start_time;
+#ifdef SMP
+ {
+ nat i;
+ pthread_t me = pthread_self();
+
+ for (i = 0; i < RtsFlags.ConcFlags.nNodes; i++) {
+ if (me == task_ids[i].id) {
+ task_ids[i].gc_time += gc_time;
+ task_ids[i].gc_etime += gc_etime;
+ break;
+ }
+ }
+ }
+#endif
+
if (gen == RtsFlags.GcFlags.generations-1) { /* major GC? */
if (live > MaxResidency) {
MaxResidency = live;
if (time == 0.0) time = 0.0001;
if (etime == 0.0) etime = 0.0001;
-
- fprintf(sf, "%9ld %9.9s %9.9s",
- (lnat)alloc*sizeof(W_), "", "");
- fprintf(sf, " %5.2f %5.2f\n\n", 0.0, 0.0);
+ if (RtsFlags.GcFlags.giveStats >= VERBOSE_GC_STATS) {
+ fprintf(sf, "%9ld %9.9s %9.9s", (lnat)alloc*sizeof(W_), "", "");
+ fprintf(sf, " %5.2f %5.2f\n\n", 0.0, 0.0);
+ }
GC_tot_alloc += alloc;
fprintf(sf,"\n%11ld Mb total memory in use\n\n",
mblocks_allocated * MBLOCK_SIZE / (1024 * 1024));
- MutTime = time - GC_tot_time - InitUserTime;
- if (MutTime < 0) { MutTime = 0; }
MutElapsedTime = etime - GCe_tot_time - InitElapsedTime;
if (MutElapsedTime < 0) { MutElapsedTime = 0; } /* sometimes -0.00 */
+#ifndef SMP
+ MutTime = time - GC_tot_time - InitUserTime;
+ if (MutTime < 0) { MutTime = 0; }
+
+#else /* SMP */
+ /* For SMP, we have to get the user time from each thread
+ * and try to work out the total time.
+ */
+ {
+ nat i;
+ MutTime = 0.0;
+ for (i = 0; i < RtsFlags.ConcFlags.nNodes; i++) {
+ fprintf(sf, " Task %2d: MUT time: %6.2fs, GC time: %6.2fs\n",
+ i, task_ids[i].mut_time, task_ids[i].gc_time);
+ MutTime += task_ids[i].mut_time;
+ }
+ }
+ time = MutTime + GC_tot_time + InitUserTime;
+ fprintf(sf,"\n");
+#endif
+
fprintf(sf, " INIT time %6.2fs (%6.2fs elapsed)\n",
InitUserTime, InitElapsedTime);
fprintf(sf, " MUT time %6.2fs (%6.2fs elapsed)\n",
/* -----------------------------------------------------------------------------
- * $Id: StgMiscClosures.hc,v 1.27 1999/08/25 16:11:51 simonmar Exp $
+ * $Id: StgMiscClosures.hc,v 1.28 1999/11/02 15:06:03 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>
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->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_info, &WHITEHOLE_info);
+#endif
+
TICK_ENT_BH();
/* Put ourselves on the blocking queue for this black hole */
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);
}
#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
-------------------------------------------------------------------------- */
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_)
+};
+
+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
/* -----------------------------------------------------------------------------
- * $Id: StgRun.S,v 1.2 1998/12/15 09:41:57 simonm Exp $
+ * $Id: StgRun.S,v 1.3 1999/11/02 15:06:04 simonmar Exp $
*
* Tiny assembler 'layer' between the C and STG worlds.
*
* To run an STG function from C land, call
*
- * rv = StgRun(f);
+ * rv = StgRun(f,BaseReg);
*
- * where "f" is the STG function to call.
+ * where "f" is the STG function to call, and BaseReg is the address of the
+ * RegTable for this run (we might have separate RegTables if we're running
+ * multiple threads on an SMP machine).
*
* In the end, "f" must JMP to StgReturn (defined below),
* passing the return-value "rv" in R1,
movl %ebp,12(%eax)
/*
+ * Set BaseReg
+ */
+ movl 12(%ebp),%ebx
+
+ /*
* grab the function argument from the stack, and jump to it.
*/
movl 8(%ebp),%eax
/* -----------------------------------------------------------------------------
- * $Id: StgRun.h,v 1.3 1999/02/05 16:02:59 simonm Exp $
+ * $Id: StgRun.h,v 1.4 1999/11/02 15:06:04 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
#include "Storage.h" /* for {Open,Close}Nursery functions */
-extern StgThreadReturnCode StgRun(StgFunPtr f);
+extern StgThreadReturnCode StgRun(StgFunPtr f, StgRegTable *basereg);
EXTFUN(StgReturn);
#endif STGRUN_H
/* -----------------------------------------------------------------------------
- * $Id: StgStdThunks.hc,v 1.8 1999/10/21 09:18:02 simonmar Exp $
+ * $Id: StgStdThunks.hc,v 1.9 1999/11/02 15:06:04 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
R1.p=(P_)R1.cl->payload[offset]; \
GET_SAVED_CCCS; \
Sp=Sp+sizeofW(StgHeader); \
- TICK_ENT_VIA_NODE(); \
JMP_(ENTRY_CODE(*R1.p)); \
FE_ \
} \
INFO_TABLE_SELECTOR(__sel_##offset##_upd_info, __sel_##offset##_upd_entry, offset,, EF_, 0,0);\
EF_(__sel_##offset##_upd_entry) { \
FB_ \
- TICK_ENT_THK(); \
STK_CHK_NP(UPD_FRAME_SIZE,1,); \
- UPD_BH_UPDATABLE(R1.p); \
+ UPD_BH_UPDATABLE(&__sel_##offset##_upd_info); \
PUSH_UPD_FRAME(R1.p,0); \
ENTER_CCS(R1.p); \
SAVE_CCCS(UPD_FRAME_SIZE); \
Sp[-UPD_FRAME_SIZE]=(W_)&__sel_ret_##offset##_upd_info; \
R1.p = (P_)R1.cl->payload[0]; \
Sp=Sp-UPD_FRAME_SIZE; \
- TICK_ENT_VIA_NODE(); \
JMP_(ENTRY_CODE(*R1.p)); \
FE_ \
}
R1.p=(P_)R1.cl->payload[offset]; \
GET_SAVED_CCCS; \
Sp=Sp+sizeofW(StgHeader); \
- TICK_ENT_VIA_NODE(); \
JMP_(ENTRY_CODE(*R1.p)); \
FE_ \
} \
INFO_TABLE_SELECTOR(__sel_##offset##_noupd_info, __sel_##offset##_noupd_entry, offset,, EF_, 0,0);\
EF_(__sel_##offset##_noupd_entry) { \
FB_ \
- TICK_ENT_THK(); \
STK_CHK_NP(NOUPD_FRAME_SIZE,1,) \
+ UPD_BH_SINGLE_ENTRY(&__sel_##offset##_noupd_info); \
ENTER_CCS(R1.p); \
SAVE_CCCS(NOUPD_FRAME_SIZE); \
Sp[-NOUPD_FRAME_SIZE]=(W_)&__sel_ret_##offset##_noupd_info; \
R1.p = (P_)R1.cl->payload[0]; \
Sp=Sp-NOUPD_FRAME_SIZE; \
- TICK_ENT_VIA_NODE(); \
JMP_(ENTRY_CODE(*R1.p)); \
FE_ \
}
INFO_TABLE_SRT(__ap_1_upd_info,__ap_1_upd_entry,1,0,0,0,0,THUNK,,EF_,0,0);
FN_(__ap_1_upd_entry) {
FB_
- TICK_ENT_THK();
STK_CHK_NP(sizeofW(StgUpdateFrame),1,);
- UPD_BH_UPDATABLE(R1.p);
+ UPD_BH_UPDATABLE(&__ap_1_upd_info);
ENTER_CCS(R1.p);
PUSH_UPD_FRAME(R1.p,0);
R1.p=(P_)(R1.cl->payload[0]);
Sp = Sp - sizeofW(StgUpdateFrame);
- TICK_ENT_VIA_NODE();
JMP_(ENTRY_CODE(*R1.p));
FE_
}
INFO_TABLE_SRT(__ap_2_upd_info,__ap_2_upd_entry,2,0,0,0,0,THUNK,,EF_,0,0);
FN_(__ap_2_upd_entry) {
FB_
- TICK_ENT_THK();
STK_CHK_NP(sizeofW(StgUpdateFrame)+1,1,);
- UPD_BH_UPDATABLE(R1.p);
+ UPD_BH_UPDATABLE(&__ap_2_upd_info);
ENTER_CCS(R1.p);
PUSH_UPD_FRAME(R1.p,0);
Sp[-UF_SIZE-1]=(W_)(R1.cl->payload[1]);
R1.p=(P_)(R1.cl->payload[0]);
Sp = Sp - (sizeofW(StgUpdateFrame)+1);
- TICK_ENT_VIA_NODE();
JMP_(ENTRY_CODE(*R1.p));
FE_
}
INFO_TABLE_SRT(__ap_3_upd_info,__ap_3_upd_entry,3,0,0,0,0,THUNK,,EF_,0,0);
FN_(__ap_3_upd_entry) {
FB_
- TICK_ENT_THK();
STK_CHK_NP(sizeofW(StgUpdateFrame)+2,1,);
- UPD_BH_UPDATABLE(R1.p);
+ UPD_BH_UPDATABLE(&__ap_3_upd_info);
ENTER_CCS(R1.p);
PUSH_UPD_FRAME(R1.p,0);
Sp[-UF_SIZE-1]=(W_)(R1.cl->payload[2]);
Sp[-UF_SIZE-2]=(W_)(R1.cl->payload[1]);
R1.p=(P_)(R1.cl->payload[0]);
Sp = Sp - (sizeofW(StgUpdateFrame)+2);
- TICK_ENT_VIA_NODE();
JMP_(ENTRY_CODE(*R1.p));
FE_
}
INFO_TABLE_SRT(__ap_4_upd_info,__ap_4_upd_entry,4,0,0,0,0,THUNK,,EF_,0,0);
FN_(__ap_4_upd_entry) {
FB_
- TICK_ENT_THK();
STK_CHK_NP(sizeofW(StgUpdateFrame)+3,1,);
- UPD_BH_UPDATABLE(R1.p);
+ UPD_BH_UPDATABLE(&__ap_4_upd_info);
ENTER_CCS(R1.p);
PUSH_UPD_FRAME(R1.p,0);
Sp[-UF_SIZE-1]=(W_)(R1.cl->payload[3]);
Sp[-UF_SIZE-3]=(W_)(R1.cl->payload[1]);
R1.p=(P_)(R1.cl->payload[0]);
Sp = Sp - (sizeofW(StgUpdateFrame)+3);
- TICK_ENT_VIA_NODE();
JMP_(ENTRY_CODE(*R1.p));
FE_
}
INFO_TABLE_SRT(__ap_5_upd_info,__ap_5_upd_entry,5,0,0,0,0,THUNK,,EF_,0,0);
FN_(__ap_5_upd_entry) {
FB_
- TICK_ENT_THK();
STK_CHK_NP(sizeofW(StgUpdateFrame)+4,1,);
- UPD_BH_UPDATABLE(R1.p);
+ UPD_BH_UPDATABLE(&__ap_5_upd_info);
ENTER_CCS(R1.p);
PUSH_UPD_FRAME(R1.p,0);
Sp[-UF_SIZE-1]=(W_)(R1.cl->payload[4]);
Sp[-UF_SIZE-4]=(W_)(R1.cl->payload[1]);
R1.p=(P_)(R1.cl->payload[0]);
Sp = Sp - (sizeofW(StgUpdateFrame)+4);
- TICK_ENT_VIA_NODE();
JMP_(ENTRY_CODE(*R1.p));
FE_
}
INFO_TABLE_SRT(__ap_6_upd_info,__ap_6_upd_entry,6,0,0,0,0,THUNK,,EF_,0,0);
FN_(__ap_6_upd_entry) {
FB_
- TICK_ENT_THK();
STK_CHK_NP(sizeofW(StgUpdateFrame)+5,1,);
- UPD_BH_UPDATABLE(R1.p);
+ UPD_BH_UPDATABLE(&__ap_6_upd_info);
ENTER_CCS(R1.p);
PUSH_UPD_FRAME(R1.p,0);
Sp[-UF_SIZE-1]=(W_)(R1.cl->payload[5]);
Sp[-UF_SIZE-5]=(W_)(R1.cl->payload[1]);
R1.p=(P_)(R1.cl->payload[0]);
Sp = Sp - (sizeofW(StgUpdateFrame)+5);
- TICK_ENT_VIA_NODE();
JMP_(ENTRY_CODE(*R1.p));
FE_
}
INFO_TABLE_SRT(__ap_7_upd_info,__ap_7_upd_entry,7,0,0,0,0,THUNK,,EF_,0,0);
FN_(__ap_7_upd_entry) {
FB_
- TICK_ENT_THK();
STK_CHK_NP(sizeofW(StgUpdateFrame)+6,1,);
- UPD_BH_UPDATABLE(R1.p);
+ UPD_BH_UPDATABLE(&__ap_7_upd_info);
ENTER_CCS(R1.p);
PUSH_UPD_FRAME(R1.p,0);
Sp[-UF_SIZE-1]=(W_)(R1.cl->payload[6]);
Sp[-UF_SIZE-6]=(W_)(R1.cl->payload[1]);
R1.p=(P_)(R1.cl->payload[0]);
Sp = Sp - (sizeofW(StgUpdateFrame)+6);
- TICK_ENT_VIA_NODE();
JMP_(ENTRY_CODE(*R1.p));
FE_
}
INFO_TABLE_SRT(__ap_8_upd_info,__ap_8_upd_entry,8,0,0,0,0,THUNK,,EF_,0,0);
FN_(__ap_8_upd_entry) {
FB_
- TICK_ENT_THK();
STK_CHK_NP(sizeofW(StgUpdateFrame)+7,1,);
- UPD_BH_UPDATABLE(R1.p);
+ UPD_BH_UPDATABLE(&__ap_8_upd_info);
ENTER_CCS(R1.p);
PUSH_UPD_FRAME(R1.p,0);
Sp[-UF_SIZE-1]=(W_)(R1.cl->payload[7]);
Sp[-UF_SIZE-7]=(W_)(R1.cl->payload[1]);
R1.p=(P_)(R1.cl->payload[0]);
Sp=Sp-10;
- TICK_ENT_VIA_NODE();
JMP_(ENTRY_CODE(*R1.p));
FE_
}
/* -----------------------------------------------------------------------------
- * $Id: Storage.c,v 1.19 1999/10/13 16:39:23 simonmar Exp $
+ * $Id: Storage.c,v 1.20 1999/11/02 15:06:04 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
#include "Sanity.h"
#include "Storage.h"
+#include "Schedule.h"
#include "StoragePriv.h"
-bdescr *current_nursery; /* next available nursery block, or NULL */
+#ifndef SMP
nat nursery_blocks; /* number of blocks in the nursery */
+#endif
StgClosure *caf_list = NULL;
step *g0s0; /* generation 0, step 0, for convenience */
/*
+ * Storage manager mutex: protects all the above state from
+ * simultaneous access by two STG threads.
+ */
+#ifdef SMP
+pthread_mutex_t sm_mutex = PTHREAD_MUTEX_INITIALIZER;
+#endif
+
+/*
* Forward references
*/
static void *stgAllocForGMP (size_t size_in_bytes);
* don't want it to be a big one. This vague idea is borne out by
* rigorous experimental evidence.
*/
- step = &generations[0].steps[0];
- g0s0 = step;
- nursery_blocks = RtsFlags.GcFlags.minAllocAreaSize;
- step->blocks = allocNursery(NULL, nursery_blocks);
- step->n_blocks = nursery_blocks;
- current_nursery = step->blocks;
- g0s0->to_space = NULL;
- /* hp, hpLim, hp_bd, to_space etc. aren't used in G0S0 */
+ g0s0 = &generations[0].steps[0];
+
+ allocNurseries();
weak_ptr_list = NULL;
caf_list = NULL;
mp_set_memory_functions(stgAllocForGMP, stgReallocForGMP, stgDeallocForGMP);
#endif
+#ifdef SMP
+ pthread_mutex_init(&sm_mutex, NULL);
+#endif
+
IF_DEBUG(gc, stat_describe_gens());
}
-extern bdescr *
+void
+exitStorage (void)
+{
+ stat_exit(calcAllocated());
+}
+
+void
+newCAF(StgClosure* caf)
+{
+ /* Put this CAF on the mutable list for the old generation.
+ * This is a HACK - the IND_STATIC closure doesn't really have
+ * a mut_link field, but we pretend it has - in fact we re-use
+ * the STATIC_LINK field for the time being, because when we
+ * come to do a major GC we won't need the mut_link field
+ * any more and can use it as a STATIC_LINK.
+ */
+ ACQUIRE_LOCK(&sm_mutex);
+ ((StgMutClosure *)caf)->mut_link = oldest_gen->mut_once_list;
+ oldest_gen->mut_once_list = (StgMutClosure *)caf;
+
+#ifdef DEBUG
+ {
+ const StgInfoTable *info;
+
+ info = get_itbl(caf);
+ ASSERT(info->type == IND_STATIC);
+#if 0
+ STATIC_LINK2(info,caf) = caf_list;
+ caf_list = caf;
+#endif
+ }
+#endif
+ RELEASE_LOCK(&sm_mutex);
+}
+
+/* -----------------------------------------------------------------------------
+ Nursery management.
+ -------------------------------------------------------------------------- */
+
+void
+allocNurseries( void )
+{
+#ifdef SMP
+ {
+ Capability *cap;
+
+ g0s0->blocks = NULL;
+ g0s0->n_blocks = 0;
+ for (cap = free_capabilities; cap != NULL; cap = cap->link) {
+ cap->rNursery = allocNursery(NULL, RtsFlags.GcFlags.minAllocAreaSize);
+ cap->rCurrentNursery = cap->rNursery;
+ }
+ }
+#else /* SMP */
+ nursery_blocks = RtsFlags.GcFlags.minAllocAreaSize;
+ g0s0->blocks = allocNursery(NULL, nursery_blocks);
+ g0s0->n_blocks = nursery_blocks;
+ g0s0->to_space = NULL;
+ MainRegTable.rNursery = g0s0->blocks;
+ MainRegTable.rCurrentNursery = g0s0->blocks;
+ /* hp, hpLim, hp_bd, to_space etc. aren't used in G0S0 */
+#endif
+}
+
+void
+resetNurseries( void )
+{
+ bdescr *bd;
+#ifdef SMP
+ Capability *cap;
+
+ /* All tasks must be stopped */
+ ASSERT(n_free_capabilities == RtsFlags.ConcFlags.nNodes);
+
+ for (cap = free_capabilities; cap != NULL; cap = cap->link) {
+ for (bd = cap->rNursery; bd; bd = bd->link) {
+ bd->free = bd->start;
+ ASSERT(bd->gen == g0);
+ ASSERT(bd->step == g0s0);
+ IF_DEBUG(sanity,memset(bd->start, 0xaa, BLOCK_SIZE));
+ }
+ cap->rCurrentNursery = cap->rNursery;
+ }
+#else
+ for (bd = g0s0->blocks; bd; bd = bd->link) {
+ bd->free = bd->start;
+ ASSERT(bd->gen == g0);
+ ASSERT(bd->step == g0s0);
+ IF_DEBUG(sanity,memset(bd->start, 0xaa, BLOCK_SIZE));
+ }
+ MainRegTable.rNursery = g0s0->blocks;
+ MainRegTable.rCurrentNursery = g0s0->blocks;
+#endif
+}
+
+bdescr *
allocNursery (bdescr *last_bd, nat blocks)
{
bdescr *bd;
return last_bd;
}
-extern void
+void
resizeNursery ( nat blocks )
{
bdescr *bd;
+#ifdef SMP
+ barf("resizeNursery: can't resize in SMP mode");
+#endif
+
if (nursery_blocks == blocks) {
ASSERT(g0s0->n_blocks == blocks);
return;
g0s0->n_blocks = nursery_blocks = blocks;
}
-void
-exitStorage (void)
-{
- lnat allocated;
- bdescr *bd;
-
- /* Return code ignored for now */
- /* ToDo: allocation figure is slightly wrong (see also GarbageCollect()) */
- allocated = (nursery_blocks * BLOCK_SIZE_W) + allocated_bytes();
- for ( bd = current_nursery->link; bd != NULL; bd = bd->link ) {
- allocated -= BLOCK_SIZE_W;
- }
- stat_exit(allocated);
-}
-
-void
-newCAF(StgClosure* caf)
-{
- /* Put this CAF on the mutable list for the old generation.
- * This is a HACK - the IND_STATIC closure doesn't really have
- * a mut_link field, but we pretend it has - in fact we re-use
- * the STATIC_LINK field for the time being, because when we
- * come to do a major GC we won't need the mut_link field
- * any more and can use it as a STATIC_LINK.
- */
- ((StgMutClosure *)caf)->mut_link = oldest_gen->mut_once_list;
- oldest_gen->mut_once_list = (StgMutClosure *)caf;
-
-#ifdef DEBUG
- {
- const StgInfoTable *info;
-
- info = get_itbl(caf);
- ASSERT(info->type == IND_STATIC);
-#if 0
- STATIC_LINK2(info,caf) = caf_list;
- caf_list = caf;
-#endif
- }
-#endif
-}
-
/* -----------------------------------------------------------------------------
The allocate() interface
bdescr *bd;
StgPtr p;
+ ACQUIRE_LOCK(&sm_mutex);
+
TICK_ALLOC_HEAP_NOCTR(n);
CCS_ALLOC(CCCS,n);
* (eg. running threads), so garbage collecting early won't make
* much difference.
*/
+ RELEASE_LOCK(&sm_mutex);
return bd->start;
/* small allocation (<LARGE_OBJECT_THRESHOLD) */
p = alloc_Hp;
alloc_Hp += n;
+ RELEASE_LOCK(&sm_mutex);
return p;
}
}
/* -----------------------------------------------------------------------------
- Stats and stuff
- -------------------------------------------------------------------------- */
+ * Stats and stuff
+ * -------------------------------------------------------------------------- */
+
+/* -----------------------------------------------------------------------------
+ * calcAllocated()
+ *
+ * Approximate how much we've allocated: number of blocks in the
+ * nursery + blocks allocated via allocate() - unused nusery blocks.
+ * This leaves a little slop at the end of each block, and doesn't
+ * take into account large objects (ToDo).
+ * -------------------------------------------------------------------------- */
+
+lnat
+calcAllocated( void )
+{
+ nat allocated;
+ bdescr *bd;
+
+#ifdef SMP
+ Capability *cap;
+
+ /* All tasks must be stopped */
+ ASSERT(n_free_capabilities == RtsFlags.ConcFlags.nNodes);
+
+ allocated =
+ n_free_capabilities * RtsFlags.GcFlags.minAllocAreaSize * BLOCK_SIZE_W
+ + allocated_bytes();
+
+ for (cap = free_capabilities; cap != NULL; cap = cap->link) {
+ for ( bd = cap->rCurrentNursery->link; bd != NULL; bd = bd->link ) {
+ allocated -= BLOCK_SIZE_W;
+ }
+ if (cap->rCurrentNursery->free < cap->rCurrentNursery->start
+ + BLOCK_SIZE_W) {
+ allocated -= (cap->rCurrentNursery->start + BLOCK_SIZE_W)
+ - cap->rCurrentNursery->free;
+ }
+ }
+
+#else /* !SMP */
+ bdescr *current_nursery = MainRegTable.rCurrentNursery;
+
+ allocated = (nursery_blocks * BLOCK_SIZE_W) + allocated_bytes();
+ for ( bd = current_nursery->link; bd != NULL; bd = bd->link ) {
+ allocated -= BLOCK_SIZE_W;
+ }
+ if (current_nursery->free < current_nursery->start + BLOCK_SIZE_W) {
+ allocated -= (current_nursery->start + BLOCK_SIZE_W)
+ - current_nursery->free;
+ }
+#endif
+
+ return allocated;
+}
/* Approximate the amount of live data in the heap. To be called just
* after garbage collection (see GarbageCollect()).
*/
if (bd->blocks > BLOCKS_PER_MBLOCK) {
total_blocks -= (MBLOCK_SIZE / BLOCK_SIZE - BLOCKS_PER_MBLOCK)
- * bd->blocks/(MBLOCK_SIZE/BLOCK_SIZE);
+ * (bd->blocks/(MBLOCK_SIZE/BLOCK_SIZE));
}
}
}
/* -----------------------------------------------------------------------------
- * $Id: Storage.h,v 1.9 1999/05/11 16:47:59 keithw Exp $
+ * $Id: Storage.h,v 1.10 1999/11/02 15:06:05 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
lnat allocated_bytes(void) Returns the number of bytes allocated
via allocate() since the last GC.
Used in the reoprting of statistics.
+
+ SMP: allocate and doYouWantToGC can be used from STG code, they are
+ surrounded by a mutex.
-------------------------------------------------------------------------- */
extern StgPtr allocate(nat n);
-------------------------------------------------------------------------- */
#define ExtendNursery(hp,hplim) \
- (current_nursery->free = (P_)(hp)+1, \
- current_nursery->link == NULL ? rtsFalse : \
- (current_nursery = current_nursery->link, \
+ (CurrentNursery->free = (P_)(hp)+1, \
+ CurrentNursery->link == NULL ? rtsFalse : \
+ (CurrentNursery = CurrentNursery->link, \
OpenNursery(hp,hplim), \
rtsTrue))
{
bdescr *bd;
+#ifdef SMP
+ ASSERT(p->header.info == &WHITEHOLE_info || closure_MUTABLE(p));
+#else
ASSERT(closure_MUTABLE(p));
+#endif
bd = Bdescr((P_)p);
if (bd->gen->no > 0) {
}
}
-static inline void
-updateWithIndirection(StgClosure *p1, StgClosure *p2)
-{
- bdescr *bd;
-
- bd = Bdescr((P_)p1);
- if (bd->gen->no == 0) {
- SET_INFO(p1,&IND_info);
- ((StgInd *)p1)->indirectee = p2;
- TICK_UPD_NEW_IND();
- } else {
- SET_INFO(p1,&IND_OLDGEN_info);
- ((StgIndOldGen *)p1)->indirectee = p2;
- ((StgIndOldGen *)p1)->mut_link = bd->gen->mut_once_list;
- bd->gen->mut_once_list = (StgMutClosure *)p1;
- TICK_UPD_OLD_IND();
+#define updateWithIndirection(p1, p2) \
+ { \
+ bdescr *bd; \
+ \
+ bd = Bdescr((P_)p1); \
+ if (bd->gen->no == 0) { \
+ ((StgInd *)p1)->indirectee = p2; \
+ SET_INFO(p1,&IND_info); \
+ TICK_UPD_NEW_IND(); \
+ } else { \
+ ((StgIndOldGen *)p1)->indirectee = p2; \
+ ((StgIndOldGen *)p1)->mut_link = bd->gen->mut_once_list; \
+ bd->gen->mut_once_list = (StgMutClosure *)p1; \
+ SET_INFO(p1,&IND_OLDGEN_info); \
+ TICK_UPD_OLD_IND(); \
+ } \
}
-}
#if defined(TICKY_TICKY) || defined(PROFILING)
static inline void
bd = Bdescr((P_)p1);
if (bd->gen->no == 0) {
- SET_INFO(p1,&IND_PERM_info);
((StgInd *)p1)->indirectee = p2;
+ SET_INFO(p1,&IND_PERM_info);
TICK_UPD_NEW_PERM_IND(p1);
} else {
- SET_INFO(p1,&IND_OLDGEN_PERM_info);
((StgIndOldGen *)p1)->indirectee = p2;
((StgIndOldGen *)p1)->mut_link = bd->gen->mut_once_list;
bd->gen->mut_once_list = (StgMutClosure *)p1;
+ SET_INFO(p1,&IND_OLDGEN_PERM_info);
TICK_UPD_OLD_PERM_IND();
}
}
/* -----------------------------------------------------------------------------
- * $Id: StoragePriv.h,v 1.8 1999/02/05 16:03:02 simonm Exp $
+ * $Id: StoragePriv.h,v 1.9 1999/11/02 15:06:05 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
extern nat alloc_blocks;
extern nat alloc_blocks_lim;
-extern bdescr *allocNursery ( bdescr *last_bd, nat blocks );
-extern void resizeNursery ( nat blocks );
+/* Nursery manipulation */
+extern void allocNurseries ( void );
+extern void resetNurseries ( void );
+extern bdescr * allocNursery ( bdescr *last_bd, nat blocks );
+extern void resizeNursery ( nat blocks );
-extern lnat calcLive( void );
-extern lnat calcNeeded( void );
+/* Stats 'n' stuff */
+extern lnat calcAllocated ( void );
+extern lnat calcLive ( void );
+extern lnat calcNeeded ( void );
static inline void
dbl_link_onto(bdescr *bd, bdescr **list)
/* -----------------------------------------------------------------------------
- * $Id: Updates.hc,v 1.19 1999/09/14 12:16:36 simonmar Exp $
+ * $Id: Updates.hc,v 1.20 1999/11/02 15:06:05 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
update code.
*/
+#if defined(REG_Su)
+#define UPD_FRAME_ENTRY_TEMPLATE(label,ret) \
+ STGFUN(label); \
+ STGFUN(label) \
+ { \
+ FB_ \
+ \
+ Su = (StgUpdateFrame *)((StgUpdateFrame *)Sp)->updatee; \
+ \
+ /* Tick - it must be a con, all the paps are handled \
+ * in stg_upd_PAP and PAP_entry below \
+ */ \
+ TICK_UPD_CON_IN_NEW(sizeW_fromITBL(get_itbl(Su))); \
+ \
+ /* update the updatee with an indirection to the return value */\
+ UPD_IND(Su,R1.p); \
+ \
+ /* reset Su to the next update frame */ \
+ Su = ((StgUpdateFrame *)Sp)->link; \
+ \
+ /* remove the update frame from the stack */ \
+ Sp += sizeofW(StgUpdateFrame); \
+ \
+ JMP_(ret); \
+ FE_ \
+ }
+#else
+
#define UPD_FRAME_ENTRY_TEMPLATE(label,ret) \
STGFUN(label); \
STGFUN(label) \
JMP_(ret); \
FE_ \
}
+#endif
UPD_FRAME_ENTRY_TEMPLATE(Upd_frame_entry,ENTRY_CODE(Sp[0]));
UPD_FRAME_ENTRY_TEMPLATE(Upd_frame_0_entry,RET_VEC(Sp[0],0));
projects / ghc-hetmet.git / commitdiff