diff options
42 files changed, 1770 insertions, 420 deletions
diff --git a/ghc/compiler/absCSyn/AbsCSyn.lhs b/ghc/compiler/absCSyn/AbsCSyn.lhs index cb65a7f239..6caa9c50be 100644 --- a/ghc/compiler/absCSyn/AbsCSyn.lhs +++ b/ghc/compiler/absCSyn/AbsCSyn.lhs @@ -1,7 +1,7 @@ % % (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} @@ -473,6 +473,7 @@ data MagicId 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. diff --git a/ghc/compiler/absCSyn/CLabel.lhs b/ghc/compiler/absCSyn/CLabel.lhs index 636a2f3f99..644a13d364 100644 --- a/ghc/compiler/absCSyn/CLabel.lhs +++ b/ghc/compiler/absCSyn/CLabel.lhs @@ -1,7 +1,7 @@ % % (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} @@ -37,6 +37,7 @@ module CLabel ( mkErrorStdEntryLabel, mkUpdInfoLabel, mkTopTickyCtrLabel, + mkBlackHoleInfoTableLabel, mkCAFBlackHoleInfoTableLabel, mkSECAFBlackHoleInfoTableLabel, mkRtsPrimOpLabel, @@ -215,6 +216,7 @@ mkAsmTempLabel = AsmTempLabel 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")) diff --git a/ghc/compiler/absCSyn/PprAbsC.lhs b/ghc/compiler/absCSyn/PprAbsC.lhs index b708742ad1..ae61d06fd6 100644 --- a/ghc/compiler/absCSyn/PprAbsC.lhs +++ b/ghc/compiler/absCSyn/PprAbsC.lhs @@ -787,8 +787,8 @@ pprCCall op@(CCallOp op_str is_asm may_gc cconv) args results vol_regs 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) diff --git a/ghc/compiler/codeGen/CgClosure.lhs b/ghc/compiler/codeGen/CgClosure.lhs index dc326087c9..38c88dd999 100644 --- a/ghc/compiler/codeGen/CgClosure.lhs +++ b/ghc/compiler/codeGen/CgClosure.lhs @@ -1,7 +1,7 @@ % % (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} @@ -269,6 +269,7 @@ closureCodeBody binder_info closure_info cc [] body 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` @@ -577,7 +578,7 @@ thunkWrapper closure_info lbl thunk_code 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 @@ -624,10 +625,14 @@ blackHoleIt :: ClosureInfo -> Bool -> Code -- Only called for closures with no a 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} diff --git a/ghc/compiler/codeGen/CgTailCall.lhs b/ghc/compiler/codeGen/CgTailCall.lhs index c33c649d92..46e3b0219f 100644 --- a/ghc/compiler/codeGen/CgTailCall.lhs +++ b/ghc/compiler/codeGen/CgTailCall.lhs @@ -1,7 +1,7 @@ % % (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 $ % %******************************************************** %* * @@ -39,7 +39,8 @@ import CgRetConv ( dataReturnConvPrim, 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 @@ -55,6 +56,7 @@ import Type ( isUnLiftedType ) import TyCon ( TyCon ) import PrimOp ( PrimOp ) import Util ( zipWithEqual ) +import Unique ( mkPseudoUnique1 ) import Outputable import Panic ( panic, assertPanic ) \end{code} @@ -425,6 +427,23 @@ doTailCall arg_amodes arg_regs finish_code arity pending_assts (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* @@ -442,12 +461,14 @@ doTailCall arg_amodes arg_regs finish_code arity pending_assts -- 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 diff --git a/ghc/compiler/codeGen/ClosureInfo.lhs b/ghc/compiler/codeGen/ClosureInfo.lhs index 3b7b5a1b1b..157a6b70e2 100644 --- a/ghc/compiler/codeGen/ClosureInfo.lhs +++ b/ghc/compiler/codeGen/ClosureInfo.lhs @@ -1,7 +1,7 @@ % % (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} @@ -77,7 +77,8 @@ import CLabel ( CLabel, mkStdEntryLabel, mkFastEntryLabel, 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 @@ -679,6 +680,9 @@ getEntryConvention name lf_info arg_kinds 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) diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs index 3101d027ec..e3a5f22672 100644 --- a/ghc/compiler/main/CmdLineOpts.lhs +++ b/ghc/compiler/main/CmdLineOpts.lhs @@ -87,6 +87,7 @@ module CmdLineOpts ( opt_IrrefutableTuples, opt_NumbersStrict, opt_Parallel, + opt_SMP, -- optimisation opts opt_DoEtaReduction, @@ -375,6 +376,7 @@ opt_IrrefutableTuples = lookUp SLIT("-firrefutable-tuples") 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") diff --git a/ghc/driver/ghc.lprl b/ghc/driver/ghc.lprl index cacd94f49f..71795af4eb 100644 --- a/ghc/driver/ghc.lprl +++ b/ghc/driver/ghc.lprl @@ -352,7 +352,7 @@ $BuildTag = ''; # default is sequential build w/ Appel-style GC '_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"); @@ -3054,6 +3054,7 @@ arg: while($_ = $Args[0]) { /^-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)-/ ) { diff --git a/ghc/includes/MachRegs.h b/ghc/includes/MachRegs.h index 35db1c0f28..16d429ad63 100644 --- a/ghc/includes/MachRegs.h +++ b/ghc/includes/MachRegs.h @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $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 * @@ -206,6 +206,7 @@ #define REG_Base ebx #endif #define REG_Sp ebp +/* #define REG_Su ebx*/ #if STOLEN_X86_REGS >= 3 # define REG_R1 esi diff --git a/ghc/includes/PrimOps.h b/ghc/includes/PrimOps.h index 77e74c3d40..0991482276 100644 --- a/ghc/includes/PrimOps.h +++ b/ghc/includes/PrimOps.h @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $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 * @@ -710,6 +710,12 @@ EF_(forkzh_fast); 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) diff --git a/ghc/includes/Regs.h b/ghc/includes/Regs.h index df44cc9008..e7a9213ea8 100644 --- a/ghc/includes/Regs.h +++ b/ghc/includes/Regs.h @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $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 * @@ -25,7 +25,7 @@ * 2) caller-saves registers are saved across a CCall */ -typedef struct { +typedef struct StgRegTable_ { StgUnion rR1; StgUnion rR2; StgUnion rR3; @@ -48,9 +48,22 @@ typedef struct { 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 @@ -85,32 +98,35 @@ extern DLL_IMPORT_RTS StgRegTable MainRegTable; #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 @@ -240,6 +256,9 @@ GLOBAL_REG_DECL(StgWord64,L1,REG_L1) #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 @@ -273,6 +292,18 @@ GLOBAL_REG_DECL(P_,HpLim,REG_HpLim) #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 @@ -456,6 +487,9 @@ GLOBAL_REG_DECL(P_,HpLim,REG_HpLim) #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 @@ -463,10 +497,30 @@ GLOBAL_REG_DECL(P_,HpLim,REG_HpLim) #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 \ @@ -489,7 +543,9 @@ GLOBAL_REG_DECL(P_,HpLim,REG_HpLim) 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 \ @@ -514,7 +570,18 @@ GLOBAL_REG_DECL(P_,HpLim,REG_HpLim) 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 \ diff --git a/ghc/includes/Rts.h b/ghc/includes/Rts.h index 1dc23dd374..dd233886e0 100644 --- a/ghc/includes/Rts.h +++ b/ghc/includes/Rts.h @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $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 * @@ -10,8 +10,8 @@ #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" diff --git a/ghc/includes/RtsAPI.h b/ghc/includes/RtsAPI.h index 0e7883d8ef..aeccc7c3fd 100644 --- a/ghc/includes/RtsAPI.h +++ b/ghc/includes/RtsAPI.h @@ -1,5 +1,5 @@ /* ---------------------------------------------------------------------------- - * $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 * @@ -14,6 +14,7 @@ * Running the scheduler */ typedef enum { + NoStatus, /* not finished yet */ Success, Killed, /* another thread killed us */ Interrupted, /* stopped in response to a call to interruptStgRts */ diff --git a/ghc/includes/SMP.h b/ghc/includes/SMP.h new file mode 100644 index 0000000000..fa247988cf --- /dev/null +++ b/ghc/includes/SMP.h @@ -0,0 +1,91 @@ +/* ---------------------------------------------------------------------------- + * $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 */ diff --git a/ghc/includes/SchedAPI.h b/ghc/includes/SchedAPI.h index b682dfd686..02c308d661 100644 --- a/ghc/includes/SchedAPI.h +++ b/ghc/includes/SchedAPI.h @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $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 * @@ -17,13 +17,14 @@ * 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--; diff --git a/ghc/includes/Stg.h b/ghc/includes/Stg.h index 9b2ab0d5c0..756e8fb51a 100644 --- a/ghc/includes/Stg.h +++ b/ghc/includes/Stg.h @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $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 * @@ -16,6 +16,17 @@ #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 */ @@ -33,13 +44,17 @@ * 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. */ @@ -96,8 +111,10 @@ void _stgAssert (char *, unsigned int); #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" @@ -121,6 +138,10 @@ void _stgAssert (char *, unsigned int); #include <unistd.h> #endif +#ifdef SMP +#include <pthread.h> +#endif + /* GNU mp library */ #include "gmp.h" diff --git a/ghc/includes/StgMacros.h b/ghc/includes/StgMacros.h index 3dec7513b0..b14ab43a82 100644 --- a/ghc/includes/StgMacros.h +++ b/ghc/includes/StgMacros.h @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $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 * @@ -416,12 +416,23 @@ EDI_(stg_gen_chk_info); #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 */ @@ -642,10 +653,15 @@ extern DLL_IMPORT_DATA const StgPolyInfoTable seq_frame_info; 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) { @@ -656,6 +672,12 @@ 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 @@ -664,19 +686,30 @@ SaveThreadState(void) 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 */ diff --git a/ghc/includes/StgMiscClosures.h b/ghc/includes/StgMiscClosures.h index c1ac9f078e..d9c3489fd1 100644 --- a/ghc/includes/StgMiscClosures.h +++ b/ghc/includes/StgMiscClosures.h @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $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 * @@ -24,6 +24,9 @@ STGFUN(CAF_ENTERED_entry); 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); @@ -59,6 +62,9 @@ extern DLL_IMPORT_RTS const StgInfoTable CAF_ENTERED_info; 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; diff --git a/ghc/includes/StgStorage.h b/ghc/includes/StgStorage.h index 6b1237e384..6c9b0d3503 100644 --- a/ghc/includes/StgStorage.h +++ b/ghc/includes/StgStorage.h @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $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 * @@ -10,10 +10,6 @@ #ifndef STGSTORAGE_H #define STGSTORAGE_H -#include "Block.h" - -extern DLL_IMPORT_RTS bdescr *current_nursery; - /* ----------------------------------------------------------------------------- Allocation area for compiled code @@ -29,10 +25,10 @@ extern DLL_IMPORT_RTS bdescr *current_nursery; -------------------------------------------------------------------------- */ #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. diff --git a/ghc/includes/Updates.h b/ghc/includes/Updates.h index e33b4b3d28..cf8eabce17 100644 --- a/ghc/includes/Updates.h +++ b/ghc/includes/Updates.h @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $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 * @@ -35,10 +35,25 @@ /* 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) \ @@ -110,11 +125,12 @@ extern DLL_IMPORT_DATA const StgPolyInfoTable Upd_frame_info; 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); \ } /* ----------------------------------------------------------------------------- diff --git a/ghc/rts/BlockAlloc.h b/ghc/rts/BlockAlloc.h index ab6b199740..a2c9b2b594 100644 --- a/ghc/rts/BlockAlloc.h +++ b/ghc/rts/BlockAlloc.h @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $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 * @@ -26,7 +26,7 @@ extern void freeChain(bdescr *p); /* 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)) diff --git a/ghc/rts/ClosureFlags.c b/ghc/rts/ClosureFlags.c index b3101d0ab6..439e1b7e22 100644 --- a/ghc/rts/ClosureFlags.c +++ b/ghc/rts/ClosureFlags.c @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $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 * @@ -54,7 +54,7 @@ StgWord16 closure_flags[] = { /* 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), diff --git a/ghc/rts/GC.c b/ghc/rts/GC.c index 124e22001c..02daeec1e2 100644 --- a/ghc/rts/GC.c +++ b/ghc/rts/GC.c @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $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 * @@ -162,25 +162,8 @@ void GarbageCollect(void (*get_roots)(void)) 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 */ @@ -334,12 +317,6 @@ void GarbageCollect(void (*get_roots)(void)) 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. */ @@ -669,13 +646,7 @@ void GarbageCollect(void (*get_roots)(void)) /* 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); @@ -2919,9 +2890,10 @@ threadSqueezeStack(StgTSO *tso) #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 */ diff --git a/ghc/rts/Main.c b/ghc/rts/Main.c index 01c05e6089..a15a0375b1 100644 --- a/ghc/rts/Main.c +++ b/ghc/rts/Main.c @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $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 * @@ -13,7 +13,6 @@ #include "RtsAPI.h" #include "SchedAPI.h" #include "RtsFlags.h" -#include "Schedule.h" /* for MainTSO */ #include "RtsUtils.h" #ifdef DEBUG @@ -45,19 +44,14 @@ int main(int argc, char *argv[]) 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); diff --git a/ghc/rts/PrimOps.hc b/ghc/rts/PrimOps.hc index f1e521d0db..72a9584c62 100644 --- a/ghc/rts/PrimOps.hc +++ b/ghc/rts/PrimOps.hc @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $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 * @@ -790,6 +790,7 @@ FN_(forkzh_fast) /* 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; @@ -868,16 +869,23 @@ FN_(takeMVarzh_fast) { 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 { @@ -888,13 +896,21 @@ FN_(takeMVarzh_fast) 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_ @@ -903,17 +919,24 @@ FN_(takeMVarzh_fast) 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 @@ -927,6 +950,9 @@ FN_(putMVarzh_fast) } } + /* 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_ @@ -974,7 +1000,9 @@ FN_(waitReadzh_fast) 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_ } @@ -986,7 +1014,9 @@ FN_(waitWritezh_fast) 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_ } @@ -1003,7 +1033,9 @@ FN_(delayzh_fast) */ 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_ } diff --git a/ghc/rts/Profiling.c b/ghc/rts/Profiling.c index fdd26c2250..e6b5734b2d 100644 --- a/ghc/rts/Profiling.c +++ b/ghc/rts/Profiling.c @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $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 * @@ -356,8 +356,10 @@ AppendCCS ( CostCentreStack *ccs1, CostCentreStack *ccs2 ) 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); } diff --git a/ghc/rts/RtsAPI.c b/ghc/rts/RtsAPI.c index 79c33a8861..fb4df6ced2 100644 --- a/ghc/rts/RtsAPI.c +++ b/ghc/rts/RtsAPI.c @@ -1,5 +1,5 @@ /* ---------------------------------------------------------------------------- - * $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 * @@ -331,14 +331,16 @@ SchedulerStatus 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); } /* @@ -349,7 +351,8 @@ SchedulerStatus rts_evalIO (HaskellObj p, /*out*/HaskellObj *ret) { StgTSO* tso = createStrictIOThread(RtsFlags.GcFlags.initialStkSize, p); - return schedule(tso, ret); + scheduleThread(tso); + return waitThread(tso, ret); } /* @@ -359,7 +362,8 @@ SchedulerStatus 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. */ diff --git a/ghc/rts/RtsFlags.c b/ghc/rts/RtsFlags.c index 65cf5019b0..eac04b1d3e 100644 --- a/ghc/rts/RtsFlags.c +++ b/ghc/rts/RtsFlags.c @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $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 @@ -102,6 +102,9 @@ void initRtsFlagsDefaults(void) #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; @@ -267,6 +270,9 @@ usage_text[] = { " -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)", @@ -718,6 +724,18 @@ error = rtsTrue; } 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( diff --git a/ghc/rts/RtsFlags.h b/ghc/rts/RtsFlags.h index 01caf04813..4e2443bcd0 100644 --- a/ghc/rts/RtsFlags.h +++ b/ghc/rts/RtsFlags.h @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $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 * @@ -118,7 +118,10 @@ struct PROFILING_FLAGS { #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 diff --git a/ghc/rts/RtsStartup.c b/ghc/rts/RtsStartup.c index 7b91e403c3..9d3c99cd2c 100644 --- a/ghc/rts/RtsStartup.c +++ b/ghc/rts/RtsStartup.c @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $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 * @@ -101,6 +101,11 @@ startupHaskell(int argc, char *argv[]) */ #endif /* PAR */ + /* initialise scheduler data structures (needs to be done before + * initStorage()). + */ + initScheduler(); + /* initialize the storage manager */ initStorage(); @@ -115,8 +120,10 @@ startupHaskell(int argc, char *argv[]) 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(); @@ -176,6 +183,9 @@ shutdownHaskell(void) end_gr_simulation(); #endif + /* stop all running tasks */ + exitScheduler(); + /* clean up things from the storage manager's point of view */ exitStorage(); diff --git a/ghc/rts/Schedule.c b/ghc/rts/Schedule.c index 9ad20d106f..720386d8c7 100644 --- a/ghc/rts/Schedule.c +++ b/ghc/rts/Schedule.c @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $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 * @@ -7,6 +7,26 @@ * * ---------------------------------------------------------------------------*/ +/* 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" @@ -25,24 +45,68 @@ #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; /* @@ -50,14 +114,7 @@ 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) @@ -70,6 +127,440 @@ StgTSO *MainTSO; #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 * -------------------------------------------------------------------------- */ @@ -126,7 +617,16 @@ initThread(StgTSO *tso, nat stack_size) { 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; @@ -144,58 +644,264 @@ initThread(StgTSO *tso, nat stack_size) 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; @@ -245,14 +951,7 @@ SchedulerStatus schedule(StgTSO *main, StgClosure **ret_val) /* 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; @@ -376,7 +1075,7 @@ SchedulerStatus schedule(StgTSO *main, StgClosure **ret_val) /* 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: @@ -391,7 +1090,7 @@ SchedulerStatus schedule(StgTSO *main, StgClosure **ret_val) 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; @@ -437,14 +1136,7 @@ SchedulerStatus schedule(StgTSO *main, StgClosure **ret_val) 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 @@ -453,6 +1145,7 @@ SchedulerStatus schedule(StgTSO *main, StgClosure **ret_val) */ return Deadlock; } +#endif /* ----------------------------------------------------------------------------- Debugging: why is a thread blocked @@ -494,9 +1187,14 @@ void printThreadBlockage(StgTSO *tso) -------------------------------------------------------------------------- */ +/* 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); @@ -504,11 +1202,11 @@ static void GetRoots(void) 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); } /* ----------------------------------------------------------------------------- @@ -520,6 +1218,8 @@ static void GetRoots(void) 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); @@ -586,7 +1286,7 @@ threadStackOverflow(StgTSO *tso) 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); @@ -624,9 +1324,13 @@ threadStackOverflow(StgTSO *tso) #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; } @@ -634,7 +1338,8 @@ threadStackOverflow(StgTSO *tso) Wake up a queue that was blocked on some resource. -------------------------------------------------------------------------- */ -StgTSO *unblockOne(StgTSO *tso) +static StgTSO * +unblockOneLocked(StgTSO *tso) { StgTSO *next; @@ -642,17 +1347,34 @@ StgTSO *unblockOne(StgTSO *tso) 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); } /* ----------------------------------------------------------------------------- @@ -679,6 +1401,7 @@ unblockThread(StgTSO *tso) { StgTSO *t, **last; + ACQUIRE_LOCK(&sched_mutex); switch (tso->why_blocked) { case NotBlocked: @@ -747,6 +1470,7 @@ unblockThread(StgTSO *tso) tso->why_blocked = NotBlocked; tso->block_info.closure = NULL; PUSH_ON_RUN_QUEUE(tso); + RELEASE_LOCK(&sched_mutex); } /* ----------------------------------------------------------------------------- @@ -798,7 +1522,7 @@ raiseAsync(StgTSO *tso, StgClosure *exception) 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); @@ -869,7 +1593,7 @@ raiseAsync(StgTSO *tso, StgClosure *exception) 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); @@ -905,7 +1629,7 @@ raiseAsync(StgTSO *tso, StgClosure *exception) o->payload[1] = cf->handler; IF_DEBUG(scheduler, - fprintf(stderr, "Built "); + fprintf(stderr, "schedule: Built "); printObj((StgClosure *)o); ); @@ -931,7 +1655,7 @@ raiseAsync(StgTSO *tso, StgClosure *exception) payloadCPtr(o,0) = (StgClosure *)ap; IF_DEBUG(scheduler, - fprintf(stderr, "Built "); + fprintf(stderr, "schedule: Built "); printObj((StgClosure *)o); ); @@ -957,3 +1681,4 @@ raiseAsync(StgTSO *tso, StgClosure *exception) } barf("raiseAsync"); } + diff --git a/ghc/rts/Schedule.h b/ghc/rts/Schedule.h index 06ff4cfa32..085ad22db8 100644 --- a/ghc/rts/Schedule.h +++ b/ghc/rts/Schedule.h @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $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 * @@ -8,27 +8,79 @@ * * ---------------------------------------------------------------------------*/ -/* - * 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; @@ -36,17 +88,34 @@ 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; \ @@ -55,7 +124,33 @@ extern StgTSO *MainTSO; /* temporary hack */ } \ 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; \ @@ -64,4 +159,16 @@ extern StgTSO *MainTSO; /* temporary hack */ } \ 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 + diff --git a/ghc/rts/Signals.c b/ghc/rts/Signals.c index 6e5d859fda..730ede485b 100644 --- a/ghc/rts/Signals.c +++ b/ghc/rts/Signals.c @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $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 * @@ -245,16 +245,37 @@ start_signal_handlers(void) } #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 @@ -265,6 +286,9 @@ init_shutdown_handler() { struct sigaction action,oact; +#ifdef SMP + startup_guy = pthread_self(); +#endif action.sa_handler = shutdown_handler; sigemptyset(&action.sa_mask); action.sa_flags = 0; diff --git a/ghc/rts/Stats.c b/ghc/rts/Stats.c index 50985fd1ae..c82827d458 100644 --- a/ghc/rts/Stats.c +++ b/ghc/rts/Stats.c @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $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 * @@ -14,41 +14,7 @@ #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 @@ -369,8 +335,10 @@ stat_endGC(lnat alloc, lnat collect, lnat live, lnat copied, lnat gen) 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(); @@ -378,8 +346,8 @@ stat_endGC(lnat alloc, lnat collect, lnat live, lnat copied, lnat gen) 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, @@ -397,6 +365,21 @@ stat_endGC(lnat alloc, lnat collect, lnat live, lnat copied, lnat gen) 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; @@ -434,10 +417,10 @@ stat_exit(int alloc) 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; @@ -465,11 +448,30 @@ stat_exit(int 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", diff --git a/ghc/rts/StgMiscClosures.hc b/ghc/rts/StgMiscClosures.hc index 671177fef9..6586e10748 100644 --- a/ghc/rts/StgMiscClosures.hc +++ b/ghc/rts/StgMiscClosures.hc @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $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 * @@ -14,6 +14,7 @@ #include "Storage.h" #include "StoragePriv.h" #include "ProfRts.h" +#include "SMP.h" #ifdef HAVE_STDIO_H #include <stdio.h> @@ -183,17 +184,20 @@ INFO_TABLE(BLACKHOLE_info, BLACKHOLE_entry,0,2,BLACKHOLE,,EF_,0,0); STGFUN(BLACKHOLE_entry) { FB_ +#ifdef SMP + CMPXCHG(R1.cl->header.info, &BLACKHOLE_info, &WHITEHOLE_info); +#endif + TICK_ENT_BH(); - /* Change the BLACKHOLE into a BLACKHOLE_BQ */ - ((StgBlockingQueue *)R1.p)->header.info = &BLACKHOLE_BQ_info; /* Put ourselves on the blocking queue for this black hole */ CurrentTSO->link = (StgTSO *)&END_TSO_QUEUE_closure; ((StgBlockingQueue *)R1.p)->blocking_queue = CurrentTSO; CurrentTSO->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_ @@ -203,6 +207,10 @@ INFO_TABLE(BLACKHOLE_BQ_info, BLACKHOLE_BQ_entry,1,1,BLACKHOLE_BQ,,EF_,0,0); 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 */ @@ -210,6 +218,9 @@ STGFUN(BLACKHOLE_BQ_entry) 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); @@ -245,6 +256,16 @@ STGFUN(SE_CAF_BLACKHOLE_entry) } #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 -------------------------------------------------------------------------- */ @@ -367,6 +388,19 @@ INFO_TABLE(MUT_CONS_info, MUT_CONS_entry, 1, 1, MUT_VAR, , EF_, 0, 0); NON_ENTERABLE_ENTRY_CODE(MUT_CONS); /* ----------------------------------------------------------------------------- + Exception lists + -------------------------------------------------------------------------- */ + +INFO_TABLE_CONSTR(END_EXCEPTION_LIST_info,END_EXCEPTION_LIST_entry,0,0,0,CONSTR_NOCAF_STATIC,,EF_,0,0); +NON_ENTERABLE_ENTRY_CODE(END_EXCEPTION_LIST); + +SET_STATIC_HDR(END_EXCEPTION_LIST_closure,END_EXCEPTION_LIST_info,0/*CC*/,,EI_) +}; + +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 diff --git a/ghc/rts/StgRun.S b/ghc/rts/StgRun.S index 6451567d99..a2ba9efd6d 100644 --- a/ghc/rts/StgRun.S +++ b/ghc/rts/StgRun.S @@ -1,13 +1,15 @@ /* ----------------------------------------------------------------------------- - * $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, @@ -69,6 +71,11 @@ StgRun: 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 diff --git a/ghc/rts/StgRun.h b/ghc/rts/StgRun.h index b617581f82..3dc948b6ed 100644 --- a/ghc/rts/StgRun.h +++ b/ghc/rts/StgRun.h @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $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 * @@ -12,7 +12,7 @@ #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 diff --git a/ghc/rts/StgStdThunks.hc b/ghc/rts/StgStdThunks.hc index b54148f469..42c06a3dc7 100644 --- a/ghc/rts/StgStdThunks.hc +++ b/ghc/rts/StgStdThunks.hc @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $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 * @@ -46,7 +46,6 @@ R1.p=(P_)R1.cl->payload[offset]; \ GET_SAVED_CCCS; \ Sp=Sp+sizeofW(StgHeader); \ - TICK_ENT_VIA_NODE(); \ JMP_(ENTRY_CODE(*R1.p)); \ FE_ \ } \ @@ -55,16 +54,14 @@ 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_ \ } @@ -93,7 +90,6 @@ SELECTOR_CODE_UPD(15); R1.p=(P_)R1.cl->payload[offset]; \ GET_SAVED_CCCS; \ Sp=Sp+sizeofW(StgHeader); \ - TICK_ENT_VIA_NODE(); \ JMP_(ENTRY_CODE(*R1.p)); \ FE_ \ } \ @@ -102,14 +98,13 @@ SELECTOR_CODE_UPD(15); 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_ \ } @@ -163,14 +158,12 @@ FN_(__ap_8_upd_entry); 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_ } @@ -178,15 +171,13 @@ FN_(__ap_1_upd_entry) { 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_ } @@ -194,16 +185,14 @@ FN_(__ap_2_upd_entry) { 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_ } @@ -211,9 +200,8 @@ FN_(__ap_3_upd_entry) { 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]); @@ -221,7 +209,6 @@ FN_(__ap_4_upd_entry) { 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_ } @@ -229,9 +216,8 @@ FN_(__ap_4_upd_entry) { 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]); @@ -240,7 +226,6 @@ FN_(__ap_5_upd_entry) { 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_ } @@ -248,9 +233,8 @@ FN_(__ap_5_upd_entry) { 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]); @@ -260,7 +244,6 @@ FN_(__ap_6_upd_entry) { 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_ } @@ -268,9 +251,8 @@ FN_(__ap_6_upd_entry) { 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]); @@ -281,7 +263,6 @@ FN_(__ap_7_upd_entry) { 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_ } @@ -289,9 +270,8 @@ FN_(__ap_7_upd_entry) { 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]); @@ -303,7 +283,6 @@ FN_(__ap_8_upd_entry) { 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_ } diff --git a/ghc/rts/Storage.c b/ghc/rts/Storage.c index fc3c409af6..0bf3e21555 100644 --- a/ghc/rts/Storage.c +++ b/ghc/rts/Storage.c @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $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 * @@ -19,10 +19,12 @@ #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; @@ -40,6 +42,14 @@ generation *oldest_gen; /* oldest generation, for convenience */ 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); @@ -156,14 +166,9 @@ initStorage (void) * 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; @@ -179,10 +184,109 @@ initStorage (void) 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; @@ -201,11 +305,15 @@ allocNursery (bdescr *last_bd, nat blocks) 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; @@ -233,48 +341,6 @@ resizeNursery ( nat blocks ) 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 @@ -289,6 +355,8 @@ allocate(nat n) bdescr *bd; StgPtr p; + ACQUIRE_LOCK(&sm_mutex); + TICK_ALLOC_HEAP_NOCTR(n); CCS_ALLOC(CCCS,n); @@ -307,6 +375,7 @@ allocate(nat 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) */ @@ -327,6 +396,7 @@ allocate(nat n) p = alloc_Hp; alloc_Hp += n; + RELEASE_LOCK(&sm_mutex); return p; } @@ -389,8 +459,60 @@ stgDeallocForGMP (void *ptr STG_UNUSED, } /* ----------------------------------------------------------------------------- - 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()). @@ -488,7 +610,7 @@ memInventory(void) */ 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)); } } } diff --git a/ghc/rts/Storage.h b/ghc/rts/Storage.h index eb0b241ca5..a1e43dc1d2 100644 --- a/ghc/rts/Storage.h +++ b/ghc/rts/Storage.h @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $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 * @@ -38,6 +38,9 @@ extern void exitStorage(void); 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); @@ -56,9 +59,9 @@ extern lnat allocated_bytes(void); -------------------------------------------------------------------------- */ #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)) @@ -100,7 +103,11 @@ recordMutable(StgMutClosure *p) { 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) { @@ -121,24 +128,23 @@ recordOldToNewPtrs(StgMutClosure *p) } } -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 @@ -148,14 +154,14 @@ updateWithPermIndirection(StgClosure *p1, StgClosure *p2) 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(); } } diff --git a/ghc/rts/StoragePriv.h b/ghc/rts/StoragePriv.h index 4326550cb6..f88e37ee13 100644 --- a/ghc/rts/StoragePriv.h +++ b/ghc/rts/StoragePriv.h @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $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 * @@ -109,11 +109,16 @@ extern nat nursery_blocks; 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) diff --git a/ghc/rts/Updates.hc b/ghc/rts/Updates.hc index aad6dc1629..f09f942b67 100644 --- a/ghc/rts/Updates.hc +++ b/ghc/rts/Updates.hc @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $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 * @@ -46,6 +46,34 @@ 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) \ @@ -72,6 +100,7 @@ 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)); |