diff options
32 files changed, 282 insertions, 468 deletions
diff --git a/ghc/compiler/codeGen/CgForeignCall.hs b/ghc/compiler/codeGen/CgForeignCall.hs index 155e30205c..e56189ae11 100644 --- a/ghc/compiler/codeGen/CgForeignCall.hs +++ b/ghc/compiler/codeGen/CgForeignCall.hs @@ -32,7 +32,7 @@ import MachOp import SMRep import ForeignCall import Constants -import StaticFlags ( opt_SccProfilingOn, opt_SMP ) +import StaticFlags ( opt_SccProfilingOn ) import Outputable import Monad ( when ) @@ -85,11 +85,10 @@ emitForeignCall results (CCall (CCallSpec target cconv safety)) args live ) stmtC (the_call vols) stmtC (CmmCall (CmmForeignCall resumeThread CCallConv) - (if opt_SMP then [(CmmGlobal BaseReg, PtrHint)] else []) - -- Assign the result to BaseReg: we might now have - -- a different Capability! Small optimisation: - -- only do this in SMP mode, where there are >1 - -- Capabilities. + [ (CmmGlobal BaseReg, PtrHint) ] + -- Assign the result to BaseReg: we + -- might now have a different + -- Capability! [ (CmmReg id, PtrHint) ] (Just vols) ) diff --git a/ghc/compiler/codeGen/CgHeapery.lhs b/ghc/compiler/codeGen/CgHeapery.lhs index 78a6f78053..184af904df 100644 --- a/ghc/compiler/codeGen/CgHeapery.lhs +++ b/ghc/compiler/codeGen/CgHeapery.lhs @@ -23,7 +23,6 @@ module CgHeapery ( #include "HsVersions.h" -import Constants ( mIN_UPD_SIZE ) import StgSyn ( AltType(..) ) import CLabel ( CLabel, mkRtsCodeLabel ) import CgUtils ( mkWordCLit, cmmRegOffW, cmmOffsetW, @@ -212,8 +211,7 @@ mkStaticClosureFields cl_info ccs caf_refs payload padding_wds | not is_caf = [] - | otherwise = replicate n (mkIntCLit 0) -- a bunch of 0s - where n = max 0 (mIN_UPD_SIZE - length payload) + | otherwise = ASSERT(null payload) [mkIntCLit 0] static_link_field | is_caf || staticClosureNeedsLink cl_info = [static_link_value] diff --git a/ghc/compiler/codeGen/CgPrimOp.hs b/ghc/compiler/codeGen/CgPrimOp.hs index 245a245cf4..7de4516af7 100644 --- a/ghc/compiler/codeGen/CgPrimOp.hs +++ b/ghc/compiler/codeGen/CgPrimOp.hs @@ -28,7 +28,7 @@ import SMRep import PrimOp ( PrimOp(..) ) import SMRep ( tablesNextToCode ) import Constants ( wORD_SIZE, wORD_SIZE_IN_BITS ) -import StaticFlags ( opt_Parallel, opt_SMP ) +import StaticFlags ( opt_Parallel ) import Outputable -- --------------------------------------------------------------------------- @@ -113,9 +113,6 @@ emitPrimOp [res_r,res_c] IntSubCOp [aa,bb] live emitPrimOp [res] ParOp [arg] live - | not (opt_Parallel || opt_SMP) - = stmtC (CmmAssign res (CmmLit (mkIntCLit 1))) - | otherwise = do -- for now, just implement this in a C function -- later, we might want to inline it. diff --git a/ghc/compiler/codeGen/ClosureInfo.lhs b/ghc/compiler/codeGen/ClosureInfo.lhs index a5362e60e0..84d9dd95ef 100644 --- a/ghc/compiler/codeGen/ClosureInfo.lhs +++ b/ghc/compiler/codeGen/ClosureInfo.lhs @@ -61,11 +61,10 @@ import SMRep -- all of it import CLabel -import Constants ( mIN_UPD_SIZE, mIN_SIZE_NonUpdHeapObject ) +import Constants ( mIN_PAYLOAD_SIZE ) import Packages ( isDllName, HomeModules ) import StaticFlags ( opt_SccProfilingOn, opt_OmitBlackHoling, - opt_Parallel, opt_DoTickyProfiling, - opt_SMP ) + opt_Parallel, opt_DoTickyProfiling ) import Id ( Id, idType, idArity, idName ) import DataCon ( DataCon, dataConTyCon, isNullaryRepDataCon, dataConName ) import Name ( Name, nameUnique, getOccName, getOccString ) @@ -387,16 +386,8 @@ Computing slop size. WARNING: this looks dodgy --- it has deep knowledge of what the storage manager does with the various representations... -Slop Requirements: - - - Updatable closures must be mIN_UPD_SIZE. - - - Heap-resident Closures must be mIN_SIZE_NonUpdHeapObject - (to make room for an StgEvacuated during GC). - -In SMP mode, we don't play the mIN_UPD_SIZE game. Instead, every -thunk gets an extra padding word in the header, which takes the -the updated value. +Slop Requirements: every thunk gets an extra padding word in the +header, which takes the the updated value. \begin{code} slopSize cl_info = computeSlopSize payload_size cl_info @@ -423,16 +414,14 @@ minPayloadSize smrep updatable BlackHoleRep -> min_upd_size GenericRep _ _ _ _ | updatable -> min_upd_size GenericRep True _ _ _ -> 0 -- static - GenericRep False _ _ _ -> mIN_SIZE_NonUpdHeapObject + GenericRep False _ _ _ -> mIN_PAYLOAD_SIZE -- ^^^^^___ dynamic where - min_upd_size - | opt_SMP = ASSERT(mIN_SIZE_NonUpdHeapObject <= - sIZEOF_StgSMPThunkHeader) - 0 -- check that we already have enough - -- room for mIN_SIZE_NonUpdHeapObject, - -- due to the extra header word in SMP - | otherwise = mIN_UPD_SIZE + min_upd_size = + ASSERT(mIN_PAYLOAD_SIZE <= sIZEOF_StgSMPThunkHeader) + 0 -- check that we already have enough + -- room for mIN_SIZE_NonUpdHeapObject, + -- due to the extra header word in SMP \end{code} %************************************************************************ @@ -600,9 +589,11 @@ getCallMethod hmods name (LFThunk _ _ updatable std_form_info is_fun) n_args -- is the fast-entry code] | 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. + {- OLD: || opt_SMP + I decided to remove this, because in SMP mode it doesn't matter + if we enter the same thunk multiple times, so the optimisation + of jumping directly to the entry code is still valid. --SDM + -} = ASSERT( n_args == 0 ) EnterIt | otherwise -- Jump direct to code for single-entry thunks diff --git a/ghc/compiler/codeGen/SMRep.lhs b/ghc/compiler/codeGen/SMRep.lhs index b0b1b140f7..c807703b13 100644 --- a/ghc/compiler/codeGen/SMRep.lhs +++ b/ghc/compiler/codeGen/SMRep.lhs @@ -43,7 +43,7 @@ import Type ( Type, typePrimRep, PrimRep(..) ) import TyCon ( TyCon, tyConPrimRep ) import MachOp-- ( MachRep(..), MachHint(..), wordRep ) import StaticFlags ( opt_SccProfilingOn, opt_GranMacros, - opt_Unregisterised, opt_SMP ) + opt_Unregisterised ) import Constants import Outputable @@ -289,8 +289,7 @@ arrPtrsHdrSize = fixedHdrSize*wORD_SIZE + sIZEOF_StgMutArrPtrs_NoHdr -- Thunks have an extra header word on SMP, so the update doesn't -- splat the payload. thunkHdrSize :: WordOff -thunkHdrSize | opt_SMP = fixedHdrSize + smp_hdr - | otherwise = fixedHdrSize +thunkHdrSize = fixedHdrSize + smp_hdr where smp_hdr = sIZEOF_StgSMPThunkHeader `quot` wORD_SIZE \end{code} diff --git a/ghc/compiler/ghci/ByteCodeAsm.lhs b/ghc/compiler/ghci/ByteCodeAsm.lhs index 5067aea2e0..e332413dae 100644 --- a/ghc/compiler/ghci/ByteCodeAsm.lhs +++ b/ghc/compiler/ghci/ByteCodeAsm.lhs @@ -254,6 +254,7 @@ mkBits findLabel st proto_insns ALLOC_AP n -> instr2 st bci_ALLOC_AP n ALLOC_PAP arity n -> instr3 st bci_ALLOC_PAP arity n MKAP off sz -> instr3 st bci_MKAP off sz + MKPAP off sz -> instr3 st bci_MKPAP off sz UNPACK n -> instr2 st bci_UNPACK n PACK dcon sz -> do (itbl_no,st2) <- itbl st dcon instr3 st2 bci_PACK itbl_no sz @@ -398,6 +399,7 @@ instrSize16s instr ALLOC_AP{} -> 2 ALLOC_PAP{} -> 3 MKAP{} -> 3 + MKPAP{} -> 3 UNPACK{} -> 2 PACK{} -> 3 LABEL{} -> 0 -- !! diff --git a/ghc/compiler/ghci/ByteCodeGen.lhs b/ghc/compiler/ghci/ByteCodeGen.lhs index f526ed9907..19db7af16b 100644 --- a/ghc/compiler/ghci/ByteCodeGen.lhs +++ b/ghc/compiler/ghci/ByteCodeGen.lhs @@ -52,7 +52,7 @@ import Bitmap ( intsToReverseBitmap, mkBitmap ) import OrdList import Constants ( wORD_SIZE ) -import Data.List ( intersperse, sortBy, zip4, zip5, partition ) +import Data.List ( intersperse, sortBy, zip4, zip6, partition ) import Foreign ( Ptr, castPtr, mallocBytes, pokeByteOff, Word8, withForeignPtr ) import Foreign.C ( CInt ) @@ -361,26 +361,28 @@ schemeE d s p (AnnLet binds (_,body)) zipE = zipEqual "schemeE" -- ToDo: don't build thunks for things with no free variables - build_thunk dd [] size bco off - = returnBc (PUSH_BCO bco - `consOL` unitOL (MKAP (off+size) size)) - build_thunk dd (fv:fvs) size bco off = do + build_thunk dd [] size bco off arity + = returnBc (PUSH_BCO bco `consOL` unitOL (mkap (off+size) size)) + where + mkap | arity == 0 = MKAP + | otherwise = MKPAP + build_thunk dd (fv:fvs) size bco off arity = do (push_code, pushed_szw) <- pushAtom dd p' (AnnVar fv) - more_push_code <- build_thunk (dd+pushed_szw) fvs size bco off + more_push_code <- build_thunk (dd+pushed_szw) fvs size bco off arity returnBc (push_code `appOL` more_push_code) alloc_code = toOL (zipWith mkAlloc sizes arities) where mkAlloc sz 0 = ALLOC_AP sz mkAlloc sz arity = ALLOC_PAP arity sz - compile_bind d' fvs x rhs size off = do + compile_bind d' fvs x rhs size arity off = do bco <- schemeR fvs (x,rhs) - build_thunk d' fvs size bco off + build_thunk d' fvs size bco off arity compile_binds = - [ compile_bind d' fvs x rhs size n - | (fvs, x, rhs, size, n) <- - zip5 fvss xs rhss sizes [n_binds, n_binds-1 .. 1] + [ compile_bind d' fvs x rhs size arity n + | (fvs, x, rhs, size, arity, n) <- + zip6 fvss xs rhss sizes arities [n_binds, n_binds-1 .. 1] ] in do body_code <- schemeE d' s p' body diff --git a/ghc/compiler/ghci/ByteCodeInstr.lhs b/ghc/compiler/ghci/ByteCodeInstr.lhs index 80788d6f39..7bd4408fff 100644 --- a/ghc/compiler/ghci/ByteCodeInstr.lhs +++ b/ghc/compiler/ghci/ByteCodeInstr.lhs @@ -89,7 +89,8 @@ data BCInstr -- To do with the heap | ALLOC_AP Int -- make an AP with this many payload words | ALLOC_PAP Int Int -- make a PAP with this arity / payload words - | MKAP Int{-ptr to AP/PAP is this far down stack-} Int{-# words-} + | MKAP Int{-ptr to AP is this far down stack-} Int{-# words-} + | MKPAP Int{-ptr to PAP is this far down stack-} Int{-# words-} | UNPACK Int -- unpack N words from t.o.s Constr | PACK DataCon Int -- after assembly, the DataCon is an index into the @@ -250,5 +251,6 @@ bciStackUse SWIZZLE{} = 0 -- so can't use this info. Not that it matters much. bciStackUse SLIDE{} = 0 bciStackUse MKAP{} = 0 +bciStackUse MKPAP{} = 0 bciStackUse PACK{} = 1 -- worst case is PACK 0 words \end{code} diff --git a/ghc/compiler/ghci/ByteCodeItbls.lhs b/ghc/compiler/ghci/ByteCodeItbls.lhs index 190da9bc4e..74346c6218 100644 --- a/ghc/compiler/ghci/ByteCodeItbls.lhs +++ b/ghc/compiler/ghci/ByteCodeItbls.lhs @@ -16,7 +16,7 @@ import NameEnv import SMRep ( typeCgRep ) import DataCon ( DataCon, dataConRepArgTys ) import TyCon ( TyCon, tyConFamilySize, isDataTyCon, tyConDataCons ) -import Constants ( mIN_SIZE_NonUpdHeapObject, wORD_SIZE ) +import Constants ( mIN_PAYLOAD_SIZE, wORD_SIZE ) import CgHeapery ( mkVirtHeapOffsets ) import FastString ( FastString(..) ) import Util ( lengthIs, listLengthCmp ) @@ -94,8 +94,8 @@ make_constr_itbls cons ptrs = ptr_wds nptrs = tot_wds - ptr_wds nptrs_really - | ptrs + nptrs >= mIN_SIZE_NonUpdHeapObject = nptrs - | otherwise = mIN_SIZE_NonUpdHeapObject - ptrs + | ptrs + nptrs >= mIN_PAYLOAD_SIZE = nptrs + | otherwise = mIN_PAYLOAD_SIZE - ptrs itbl = StgInfoTable { ptrs = fromIntegral ptrs, nptrs = fromIntegral nptrs_really, diff --git a/ghc/compiler/main/Constants.lhs b/ghc/compiler/main/Constants.lhs index 0f9f49286a..43db93249a 100644 --- a/ghc/compiler/main/Constants.lhs +++ b/ghc/compiler/main/Constants.lhs @@ -40,8 +40,7 @@ mAX_SPEC_SELECTEE_SIZE = (MAX_SPEC_SELECTEE_SIZE :: Int) mAX_SPEC_AP_SIZE = (MAX_SPEC_AP_SIZE :: Int) -- closure sizes: these do NOT include the header (see below for header sizes) -mIN_UPD_SIZE = (MIN_UPD_SIZE::Int) -mIN_SIZE_NonUpdHeapObject = (MIN_NONUPD_SIZE::Int) +mIN_PAYLOAD_SIZE = (MIN_PAYLOAD_SIZE::Int) \end{code} \begin{code} diff --git a/ghc/compiler/main/StaticFlags.hs b/ghc/compiler/main/StaticFlags.hs index ad65dfe2f4..b8177a47cd 100644 --- a/ghc/compiler/main/StaticFlags.hs +++ b/ghc/compiler/main/StaticFlags.hs @@ -32,7 +32,6 @@ module StaticFlags ( opt_MaxContextReductionDepth, opt_IrrefutableTuples, opt_Parallel, - opt_SMP, opt_RuntimeTypes, opt_Flatten, @@ -256,7 +255,6 @@ opt_DictsStrict = lookUp FSLIT("-fdicts-strict") opt_IrrefutableTuples = lookUp FSLIT("-firrefutable-tuples") opt_MaxContextReductionDepth = lookup_def_int "-fcontext-stack" mAX_CONTEXT_REDUCTION_DEPTH opt_Parallel = lookUp FSLIT("-fparallel") -opt_SMP = lookUp FSLIT("-fsmp") opt_Flatten = lookUp FSLIT("-fflatten") -- optimisation opts @@ -315,7 +313,6 @@ isStaticFlag f = "fdicts-strict", "firrefutable-tuples", "fparallel", - "fsmp", "fflatten", "fsemi-tagging", "flet-no-escape", @@ -558,15 +555,15 @@ way_details = , "-optc-DGRAN" , "-package concurrent" ]), - (WaySMP, Way "s" False "SMP" - [ "-fsmp" + (WaySMP, Way "s" True "SMP" + [ #if !defined(mingw32_TARGET_OS) - , "-optc-pthread" + "-optc-pthread" #endif #if !defined(mingw32_TARGET_OS) && !defined(freebsd_TARGET_OS) , "-optl-pthread" #endif - , "-optc-DSMP" ]), + ]), (WayNDP, Way "ndp" False "Nested data parallelism" [ "-fparr" diff --git a/ghc/includes/Bytecodes.h b/ghc/includes/Bytecodes.h index f9a5182842..73003a3002 100644 --- a/ghc/includes/Bytecodes.h +++ b/ghc/includes/Bytecodes.h @@ -52,28 +52,29 @@ #define bci_ALLOC_AP 27 #define bci_ALLOC_PAP 28 #define bci_MKAP 29 -#define bci_UNPACK 30 -#define bci_PACK 31 -#define bci_TESTLT_I 32 -#define bci_TESTEQ_I 33 -#define bci_TESTLT_F 34 -#define bci_TESTEQ_F 35 -#define bci_TESTLT_D 36 -#define bci_TESTEQ_D 37 -#define bci_TESTLT_P 38 -#define bci_TESTEQ_P 39 -#define bci_CASEFAIL 40 -#define bci_JMP 41 -#define bci_CCALL 42 -#define bci_SWIZZLE 43 -#define bci_ENTER 44 -#define bci_RETURN 45 -#define bci_RETURN_P 46 -#define bci_RETURN_N 47 -#define bci_RETURN_F 48 -#define bci_RETURN_D 49 -#define bci_RETURN_L 50 -#define bci_RETURN_V 51 +#define bci_MKPAP 30 +#define bci_UNPACK 31 +#define bci_PACK 32 +#define bci_TESTLT_I 33 +#define bci_TESTEQ_I 34 +#define bci_TESTLT_F 35 +#define bci_TESTEQ_F 36 +#define bci_TESTLT_D 37 +#define bci_TESTEQ_D 38 +#define bci_TESTLT_P 39 +#define bci_TESTEQ_P 40 +#define bci_CASEFAIL 41 +#define bci_JMP 42 +#define bci_CCALL 43 +#define bci_SWIZZLE 44 +#define bci_ENTER 45 +#define bci_RETURN 46 +#define bci_RETURN_P 47 +#define bci_RETURN_N 48 +#define bci_RETURN_F 49 +#define bci_RETURN_D 50 +#define bci_RETURN_L 51 +#define bci_RETURN_V 52 /* If a BCO definitely requires less than this many words of stack, don't include an explicit STKCHECK insn in it. The interpreter diff --git a/ghc/includes/Closures.h b/ghc/includes/Closures.h index 8487893b33..152213ba5d 100644 --- a/ghc/includes/Closures.h +++ b/ghc/includes/Closures.h @@ -36,9 +36,15 @@ typedef struct { /* ----------------------------------------------------------------------------- The SMP header - - In SMP mode, we have an extra word of padding in a thunk's header. - (Note: thunks only; other closures do not have this padding word). + + A thunk has a padding word to take the updated value. This is so + that the update doesn't overwrite the payload, so we can avoid + needing to lock the thunk during entry and update. + + Note: this doesn't apply to THUNK_STATICs, which have no payload. + + Note: we leave this padding word in all ways, rather than just SMP, + so that we don't have to recompile all our libraries for SMP. -------------------------------------------------------------------------- */ typedef struct { @@ -62,13 +68,6 @@ typedef struct { #endif } StgHeader; -/* - * In SMP mode, a thunk has a padding word to take the updated value. - * This is so that the update doesn't overwrite the payload, so we can - * avoid needing to lock the thunk during entry and update. - * - * Note: this doesn't apply to THUNK_STATICs, which have no payload. - */ typedef struct { const struct _StgInfoTable* info; #ifdef PROFILING @@ -77,11 +76,11 @@ typedef struct { #ifdef GRAN StgGranHeader gran; #endif -#ifdef SMP StgSMPThunkHeader smp; -#endif } StgThunkHeader; +#define THUNK_EXTRA_HEADER_W (sizeofW(StgThunkHeader)-sizeofW(StgHeader)) + /* ----------------------------------------------------------------------------- Closure Types diff --git a/ghc/includes/Cmm.h b/ghc/includes/Cmm.h index 5a380594be..ea760a860f 100644 --- a/ghc/includes/Cmm.h +++ b/ghc/includes/Cmm.h @@ -340,11 +340,7 @@ * the value from GHC, but it seems like too much trouble to do that * for StgThunkHeader. */ -#ifdef SMP #define SIZEOF_StgThunkHeader SIZEOF_StgHeader+SIZEOF_StgSMPThunkHeader -#else -#define SIZEOF_StgThunkHeader SIZEOF_StgHeader -#endif #define StgThunk_payload(__ptr__,__ix__) \ W_[__ptr__+SIZEOF_StgThunkHeader+ WDS(__ix__)] diff --git a/ghc/includes/Constants.h b/ghc/includes/Constants.h index d02ae4d699..4f3c35b744 100644 --- a/ghc/includes/Constants.h +++ b/ghc/includes/Constants.h @@ -20,29 +20,12 @@ /* ----------------------------------------------------------------------------- Minimum closure sizes - Here we define the minimum size for updatable closures. All updates - will be performed on closures of this size. For non-updatable closures - the minimum size is 1 to allow for a forwarding pointer. - - When we used to keep the mutable list threaded through closures on - the heap, MIN_UPD_SIZE used to be 2. Now it's 1. - - o MIN_UPD_SIZE doesn't apply to stack closures, static closures - or non-updateable objects like PAPs or CONSTRs - o MIN_UPD_SIZE is big enough to contain any of the following: - o EVACUATED - o BLACKHOLE - o BLOCKING QUEUE - o IND, IND_PERM, IND_OLDGEN and IND_OLDGEN_PERM - (it need not be big enough for IND_STATIC - but it is) - o MIN_NONUPD_SIZE doesn't apply to stack closures, static closures - or updateable objects like APs, THUNKS or THUNK_SELECTORs - o MIN_NONUPD_SIZE is big enough to contain any of the following: - o EVACUATED + This is the minimum number of words in the payload of a + heap-allocated closure, so that the closure has enough room to be + overwritten with a forwarding pointer during garbage collection. -------------------------------------------------------------------------- */ -#define MIN_UPD_SIZE 1 -#define MIN_NONUPD_SIZE 1 +#define MIN_PAYLOAD_SIZE 1 /* ----------------------------------------------------------------------------- Constants to do with specialised closure types. diff --git a/ghc/includes/Storage.h b/ghc/includes/Storage.h index 035088e26b..8cfd511662 100644 --- a/ghc/includes/Storage.h +++ b/ghc/includes/Storage.h @@ -312,10 +312,10 @@ INLINE_HEADER StgOffset CONSTR_sizeW( nat p, nat np ) { return sizeofW(StgHeader) + p + np; } INLINE_HEADER StgOffset THUNK_SELECTOR_sizeW ( void ) -{ return stg_max(sizeofW(StgHeader)+MIN_UPD_SIZE, sizeofW(StgSelector)); } +{ return sizeofW(StgSelector); } INLINE_HEADER StgOffset BLACKHOLE_sizeW ( void ) -{ return sizeofW(StgHeader)+MIN_UPD_SIZE; } +{ return sizeofW(StgHeader)+MIN_PAYLOAD_SIZE; } /* -------------------------------------------------------------------------- Sizes of closures @@ -352,6 +352,71 @@ INLINE_HEADER StgWord tso_sizeW ( StgTSO *tso ) INLINE_HEADER StgWord bco_sizeW ( StgBCO *bco ) { return bco->size; } +STATIC_INLINE nat +closure_sizeW_ (StgClosure *p, StgInfoTable *info) +{ + switch (info->type) { + case THUNK_0_1: + case THUNK_1_0: + return sizeofW(StgThunk) + 1; + case FUN_0_1: + case CONSTR_0_1: + case FUN_1_0: + case CONSTR_1_0: + return sizeofW(StgHeader) + 1; + case THUNK_0_2: + case THUNK_1_1: + case THUNK_2_0: + return sizeofW(StgThunk) + 2; + case FUN_0_2: + case CONSTR_0_2: + case FUN_1_1: + case CONSTR_1_1: + case FUN_2_0: + case CONSTR_2_0: + return sizeofW(StgHeader) + 2; + case THUNK_SELECTOR: + return THUNK_SELECTOR_sizeW(); + case AP_STACK: + return ap_stack_sizeW((StgAP_STACK *)p); + case AP: + case PAP: + return pap_sizeW((StgPAP *)p); + case IND: + case IND_PERM: + case IND_OLDGEN: + case IND_OLDGEN_PERM: + return sizeofW(StgInd); + case ARR_WORDS: + return arr_words_sizeW((StgArrWords *)p); + case MUT_ARR_PTRS_CLEAN: + case MUT_ARR_PTRS_DIRTY: + case MUT_ARR_PTRS_FROZEN: + case MUT_ARR_PTRS_FROZEN0: + return mut_arr_ptrs_sizeW((StgMutArrPtrs*)p); + case TSO: + return tso_sizeW((StgTSO *)p); + case BCO: + return bco_sizeW((StgBCO *)p); + case TVAR_WAIT_QUEUE: + return sizeofW(StgTVarWaitQueue); + case TVAR: + return sizeofW(StgTVar); + case TREC_CHUNK: + return sizeofW(StgTRecChunk); + case TREC_HEADER: + return sizeofW(StgTRecHeader); + default: + return sizeW_fromITBL(info); + } +} + +STATIC_INLINE nat +closure_sizeW (StgClosure *p) +{ + return closure_sizeW_(p, get_itbl(p)); +} + /* ----------------------------------------------------------------------------- Sizes of stack frames -------------------------------------------------------------------------- */ diff --git a/ghc/includes/mkDerivedConstants.c b/ghc/includes/mkDerivedConstants.c index c78c8427ec..27d4fa9e7b 100644 --- a/ghc/includes/mkDerivedConstants.c +++ b/ghc/includes/mkDerivedConstants.c @@ -93,13 +93,6 @@ printf("#define SIZEOF_" str " (SIZEOF_StgHeader+%d)\n", size); #endif -#if defined(GEN_HASKELL) -#define def_thunk_size(str, size) /* nothing */ -#else -#define def_thunk_size(str, size) \ - printf("#define SIZEOF_" str " (SIZEOF_StgThunkHeader+%d)\n", size); -#endif - #define struct_size(s_type) \ def_size(#s_type, sizeof(s_type)); @@ -112,64 +105,38 @@ def_closure_size(#s_type, sizeof(s_type) - sizeof(StgHeader)); #define thunk_size(s_type) \ - def_size(#s_type "_NoHdr", sizeof(s_type) - sizeof(StgHeader)); \ - def_thunk_size(#s_type, sizeof(s_type) - sizeof(StgHeader)); + def_size(#s_type "_NoThunkHdr", sizeof(s_type) - sizeof(StgThunkHeader)); \ + closure_size(s_type) /* An access macro for use in C-- sources. */ #define closure_field_macro(str) \ printf("#define " str "(__ptr__) REP_" str "[__ptr__+SIZEOF_StgHeader+OFFSET_" str "]\n"); -#define thunk_field_macro(str) \ - printf("#define " str "(__ptr__) REP_" str "[__ptr__+SIZEOF_StgThunkHeader+OFFSET_" str "]\n"); - #define closure_field_offset_(str, s_type,field) \ def_offset(str, OFFSET(s_type,field) - sizeof(StgHeader)); -#define thunk_field_offset_(str, s_type, field) \ - closure_field_offset_(str, s_type, field) - #define closure_field_offset(s_type,field) \ closure_field_offset_(str(s_type,field),s_type,field) -#define thunk_field_offset(s_type,field) \ - thunk_field_offset_(str(s_type,field),s_type,field) - #define closure_payload_macro(str) \ printf("#define " str "(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_" str " + WDS(__ix__)]\n"); -#define thunk_payload_macro(str) \ - printf("#define " str "(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgThunkHeader+OFFSET_" str " + WDS(__ix__)]\n"); - #define closure_payload(s_type,field) \ closure_field_offset_(str(s_type,field),s_type,field); \ closure_payload_macro(str(s_type,field)); -#define thunk_payload(s_type,field) \ - thunk_field_offset_(str(s_type,field),s_type,field); \ - thunk_payload_macro(str(s_type,field)); - /* Byte offset and MachRep for a closure field, minus the header */ #define closure_field(s_type, field) \ closure_field_offset(s_type,field) \ field_type(s_type, field); \ closure_field_macro(str(s_type,field)) -#define thunk_field(s_type, field) \ - thunk_field_offset(s_type,field) \ - field_type(s_type, field); \ - thunk_field_macro(str(s_type,field)) - /* Byte offset and MachRep for a closure field, minus the header */ #define closure_field_(str, s_type, field) \ closure_field_offset_(str,s_type,field) \ field_type_(str, s_type, field); \ closure_field_macro(str) -#define thunk_field_(str, s_type, field) \ - thunk_field_offset_(str,s_type,field) \ - field_type_(str, s_type, field); \ - thunk_field_macro(str) - /* Byte offset for a TSO field, minus the header and variable prof bit. */ #define tso_payload_offset(s_type, field) \ def_offset(str(s_type,field), OFFSET(s_type,field) - sizeof(StgHeader) - sizeof(StgTSOProfInfo)); @@ -337,15 +304,15 @@ main(int argc, char *argv[]) closure_field(StgPAP, arity); closure_payload(StgPAP, payload); - closure_size(StgAP); + thunk_size(StgAP); closure_field(StgAP, n_args); closure_field(StgAP, fun); closure_payload(StgAP, payload); thunk_size(StgAP_STACK); - thunk_field(StgAP_STACK, size); - thunk_field(StgAP_STACK, fun); - thunk_payload(StgAP_STACK, payload); + closure_field(StgAP_STACK, size); + closure_field(StgAP_STACK, fun); + closure_payload(StgAP_STACK, payload); closure_field(StgInd, indirectee); diff --git a/ghc/rts/Apply.cmm b/ghc/rts/Apply.cmm index a647b3754a..8d19d1402f 100644 --- a/ghc/rts/Apply.cmm +++ b/ghc/rts/Apply.cmm @@ -264,7 +264,7 @@ INFO_TABLE(stg_AP_STACK,/*special layout*/0,0,AP_STACK,"AP_STACK","AP_STACK") // Reload the stack W_ i; W_ p; - p = ap + SIZEOF_StgThunkHeader + OFFSET_StgAP_STACK_payload; + p = ap + SIZEOF_StgHeader + OFFSET_StgAP_STACK_payload; i = 0; for: if (i < Words) { diff --git a/ghc/rts/GC.c b/ghc/rts/GC.c index 7ce6a8fe1d..8a3b54ebb2 100644 --- a/ghc/rts/GC.c +++ b/ghc/rts/GC.c @@ -1696,7 +1696,7 @@ copyPart(StgClosure *src, nat size_to_reserve, nat size_to_copy, step *stp) SET_EVACUAEE_FOR_LDV(src, size_to_reserve); // fill the slop if (size_to_reserve - size_to_copy_org > 0) - FILL_SLOP(stp->hp - 1, (int)(size_to_reserve - size_to_copy_org)); + LDV_FILL_SLOP(stp->hp - 1, (int)(size_to_reserve - size_to_copy_org)); #endif return (StgClosure *)dest; } @@ -2164,7 +2164,7 @@ loop: } case BLOCKED_FETCH: - ASSERT(sizeofW(StgBlockedFetch) >= MIN_NONUPD_SIZE); + ASSERT(sizeofW(StgBlockedFetch) >= MIN_PAYLOD_SIZE); to = copy(q,sizeofW(StgBlockedFetch),stp); IF_DEBUG(gc, debugBelch("@@ evacuate: %p (%s) to %p (%s)", @@ -2175,7 +2175,7 @@ loop: case REMOTE_REF: # endif case FETCH_ME: - ASSERT(sizeofW(StgBlockedFetch) >= MIN_UPD_SIZE); + ASSERT(sizeofW(StgBlockedFetch) >= MIN_PAYLOAD_SIZE); to = copy(q,sizeofW(StgFetchMe),stp); IF_DEBUG(gc, debugBelch("@@ evacuate: %p (%s) to %p (%s)", @@ -2183,7 +2183,7 @@ loop: return to; case FETCH_ME_BQ: - ASSERT(sizeofW(StgBlockedFetch) >= MIN_UPD_SIZE); + ASSERT(sizeofW(StgBlockedFetch) >= MIN_PAYLOAD_SIZE); to = copy(q,sizeofW(StgFetchMeBlockingQueue),stp); IF_DEBUG(gc, debugBelch("@@ evacuate: %p (%s) to %p (%s)", @@ -3555,12 +3555,12 @@ linear_scan: // already scavenged? if (is_marked(oldgen_scan+1,oldgen_scan_bd)) { - oldgen_scan += sizeofW(StgHeader) + MIN_NONUPD_SIZE; + oldgen_scan += sizeofW(StgHeader) + MIN_PAYLOAD_SIZE; goto loop; } push_mark_stack(oldgen_scan); // ToDo: bump the linear scan by the actual size of the object - oldgen_scan += sizeofW(StgHeader) + MIN_NONUPD_SIZE; + oldgen_scan += sizeofW(StgHeader) + MIN_PAYLOAD_SIZE; goto linear_scan; } diff --git a/ghc/rts/GCCompact.c b/ghc/rts/GCCompact.c index b5bcc19360..4dfe84bbe0 100644 --- a/ghc/rts/GCCompact.c +++ b/ghc/rts/GCCompact.c @@ -106,60 +106,6 @@ move(StgPtr to, StgPtr from, nat size) } } -STATIC_INLINE nat -obj_sizeW( StgClosure *p, StgInfoTable *info ) -{ - switch (info->type) { - case THUNK_0_1: - case THUNK_1_0: - return sizeofW(StgThunk) + 1; - case FUN_0_1: - case CONSTR_0_1: - case FUN_1_0: - case CONSTR_1_0: - return sizeofW(StgHeader) + 1; - case THUNK_0_2: - case THUNK_1_1: - case THUNK_2_0: - return sizeofW(StgThunk) + 2; - case FUN_0_2: - case CONSTR_0_2: - case FUN_1_1: - case CONSTR_1_1: - case FUN_2_0: - case CONSTR_2_0: - return sizeofW(StgHeader) + 2; - case THUNK_SELECTOR: - return THUNK_SELECTOR_sizeW(); - case AP_STACK: - return ap_stack_sizeW((StgAP_STACK *)p); - case AP: - case PAP: - return pap_sizeW((StgPAP *)p); - case ARR_WORDS: - return arr_words_sizeW((StgArrWords *)p); - case MUT_ARR_PTRS_CLEAN: - case MUT_ARR_PTRS_DIRTY: - case MUT_ARR_PTRS_FROZEN: - case MUT_ARR_PTRS_FROZEN0: - return mut_arr_ptrs_sizeW((StgMutArrPtrs*)p); - case TSO: - return tso_sizeW((StgTSO *)p); - case BCO: - return bco_sizeW((StgBCO *)p); - case TVAR_WAIT_QUEUE: - return sizeofW(StgTVarWaitQueue); - case TVAR: - return sizeofW(StgTVar); - case TREC_CHUNK: - return sizeofW(StgTRecChunk); - case TREC_HEADER: - return sizeofW(StgTRecHeader); - default: - return sizeW_fromITBL(info); - } -} - static void thread_static( StgClosure* p ) { @@ -893,7 +839,7 @@ update_bkwd_compact( step *stp ) unthread(p,free); ASSERT(LOOKS_LIKE_INFO_PTR(((StgClosure *)p)->header.info)); info = get_itbl((StgClosure *)p); - size = obj_sizeW((StgClosure *)p,info); + size = closure_sizeW_((StgClosure *)p,info); if (free != p) { move(free,p,size); diff --git a/ghc/rts/Interpreter.c b/ghc/rts/Interpreter.c index b31ade08fb..56e9bb67ce 100644 --- a/ghc/rts/Interpreter.c +++ b/ghc/rts/Interpreter.c @@ -69,15 +69,9 @@ STATIC_INLINE StgPtr -allocate_UPD (int n_words) -{ - return allocate(stg_max(sizeofW(StgHeader)+MIN_UPD_SIZE, n_words)); -} - -STATIC_INLINE StgPtr allocate_NONUPD (int n_words) { - return allocate(stg_max(sizeofW(StgHeader)+MIN_NONUPD_SIZE, n_words)); + return allocate(stg_max(sizeofW(StgHeader)+MIN_PAYLOAD_SIZE, n_words)); } @@ -560,9 +554,7 @@ do_apply: else /* arity > n */ { // build a new PAP and return it. StgPAP *new_pap; - nat size; - size = PAP_sizeW(pap->n_args + m); - new_pap = (StgPAP *)allocate(size); + new_pap = (StgPAP *)allocate(PAP_sizeW(pap->n_args + m)); SET_HDR(new_pap,&stg_PAP_info,CCCS); new_pap->arity = pap->arity - n; new_pap->n_args = pap->n_args + m; @@ -606,9 +598,8 @@ do_apply: else /* arity > n */ { // build a PAP and return it. StgPAP *pap; - nat size, i; - size = PAP_sizeW(m); - pap = (StgPAP *)allocate(size); + nat i; + pap = (StgPAP *)allocate(PAP_sizeW(m)); SET_HDR(pap, &stg_PAP_info,CCCS); pap->arity = arity - n; pap->fun = obj; @@ -932,8 +923,7 @@ run_BCO: case bci_ALLOC_AP: { StgAP* ap; int n_payload = BCO_NEXT; - int request = PAP_sizeW(n_payload); - ap = (StgAP*)allocate_UPD(request); + ap = (StgAP*)allocate(AP_sizeW(n_payload)); Sp[-1] = (W_)ap; ap->n_args = n_payload; SET_HDR(ap, &stg_AP_info, CCS_SYSTEM/*ToDo*/) @@ -945,8 +935,7 @@ run_BCO: StgPAP* pap; int arity = BCO_NEXT; int n_payload = BCO_NEXT; - int request = PAP_sizeW(n_payload); - pap = (StgPAP*)allocate_NONUPD(request); + pap = (StgPAP*)allocate(PAP_sizeW(n_payload)); Sp[-1] = (W_)pap; pap->n_args = n_payload; pap->arity = arity; @@ -962,13 +951,12 @@ run_BCO: StgAP* ap = (StgAP*)Sp[stkoff]; ASSERT((int)ap->n_args == n_payload); ap->fun = (StgClosure*)Sp[0]; - + // The function should be a BCO, and its bitmap should // cover the payload of the AP correctly. ASSERT(get_itbl(ap->fun)->type == BCO - && (get_itbl(ap)->type == PAP || - BCO_BITMAP_SIZE(ap->fun) == ap->n_args)); - + && BCO_BITMAP_SIZE(ap->fun) == ap->n_args); + for (i = 0; i < n_payload; i++) ap->payload[i] = (StgClosure*)Sp[i+1]; Sp += n_payload+1; @@ -979,6 +967,27 @@ run_BCO: goto nextInsn; } + case bci_MKPAP: { + int i; + int stkoff = BCO_NEXT; + int n_payload = BCO_NEXT; + StgPAP* pap = (StgPAP*)Sp[stkoff]; + ASSERT((int)pap->n_args == n_payload); + pap->fun = (StgClosure*)Sp[0]; + + // The function should be a BCO + ASSERT(get_itbl(pap->fun)->type == BCO); + + for (i = 0; i < n_payload; i++) + pap->payload[i] = (StgClosure*)Sp[i+1]; + Sp += n_payload+1; + IF_DEBUG(interpreter, + debugBelch("\tBuilt "); + printObj((StgClosure*)pap); + ); + goto nextInsn; + } + case bci_UNPACK: { /* Unpack N ptr words from t.o.s constructor */ int i; diff --git a/ghc/rts/LdvProfile.c b/ghc/rts/LdvProfile.c index dfdda28ecc..355d09d028 100644 --- a/ghc/rts/LdvProfile.c +++ b/ghc/rts/LdvProfile.c @@ -37,51 +37,22 @@ void LDV_recordDead_FILL_SLOP_DYNAMIC( StgClosure *p ) { StgInfoTable *info; - nat nw, i; + nat size, i; #if defined(__GNUC__) && __GNUC__ < 3 && defined(DEBUG) #error Please use gcc 3.0+ to compile this file with DEBUG; gcc < 3.0 miscompiles it #endif if (era > 0) { - info = get_itbl((p)); - switch (info->type) { - case THUNK_1_0: - case THUNK_0_1: - nw = stg_max(MIN_UPD_SIZE,1); - break; + // very like FILL_SLOP(), except that we call LDV_recordDead(). + size = closure_sizeW(p); - case THUNK_2_0: - case THUNK_1_1: - case THUNK_0_2: - case THUNK_SELECTOR: - nw = stg_max(MIN_UPD_SIZE,2); - break; + LDV_recordDead((StgClosure *)(p), size); - case THUNK: - nw = stg_max(info->layout.payload.ptrs + info->layout.payload.nptrs, - MIN_UPD_SIZE); - break; - case AP: - nw = sizeofW(StgAP) - sizeofW(StgThunkHeader) + ((StgPAP *)p)->n_args; - break; - case AP_STACK: - nw = sizeofW(StgAP_STACK) - sizeofW(StgThunkHeader) - + ((StgAP_STACK *)p)->size; - break; - case CAF_BLACKHOLE: - case BLACKHOLE: - case SE_BLACKHOLE: - case SE_CAF_BLACKHOLE: - nw = info->layout.payload.ptrs + info->layout.payload.nptrs; - break; - default: - barf("Unexpected closure type %u in LDV_recordDead_FILL_SLOP_DYNAMIC()", info->type); - break; - } - LDV_recordDead((StgClosure *)(p), nw + sizeofW(StgHeader)); - for (i = 0; i < nw; i++) { - ((StgClosure *)(p))->payload[i] = 0; + if (size > sizeofW(StgThunkHeader)) { + for (i = 0; i < size - sizeofW(StgThunkHeader); i++) { + ((StgThunk *)(p))->payload[i] = 0; + } } } } @@ -113,96 +84,64 @@ processHeapClosureForDead( StgClosure *c ) )); } + if (info->type == EVACUATED) { + // The size of the evacuated closure is currently stored in + // the LDV field. See SET_EVACUAEE_FOR_LDV() in + // includes/StgLdvProf.h. + return LDVW(c); + } + + size = closure_sizeW(c); + switch (info->type) { /* 'inherently used' cases: do nothing. */ - case TSO: - size = tso_sizeW((StgTSO *)c); - return size; - case MVAR: - size = sizeofW(StgMVar); - return size; - case MUT_ARR_PTRS_CLEAN: case MUT_ARR_PTRS_DIRTY: case MUT_ARR_PTRS_FROZEN: case MUT_ARR_PTRS_FROZEN0: - size = mut_arr_ptrs_sizeW((StgMutArrPtrs *)c); - return size; - case ARR_WORDS: - size = arr_words_sizeW((StgArrWords *)c); - return size; - case WEAK: case MUT_VAR_CLEAN: case MUT_VAR_DIRTY: case BCO: case STABLE_NAME: - size = sizeW_fromITBL(info); return size; /* ordinary cases: call LDV_recordDead(). */ - case THUNK: - size = stg_max(sizeW_fromITBL(info), sizeofW(StgHeader) + MIN_UPD_SIZE); - break; - case THUNK_1_0: case THUNK_0_1: case THUNK_SELECTOR: - size = sizeofW(StgHeader) + stg_max(MIN_UPD_SIZE, 1); - break; - case THUNK_2_0: case THUNK_1_1: case THUNK_0_2: - size = sizeofW(StgHeader) + stg_max(MIN_UPD_SIZE, 2); - break; - case AP: - size = ap_sizeW((StgAP *)c); - break; - case PAP: - size = pap_sizeW((StgPAP *)c); - break; - case AP_STACK: - size = ap_stack_sizeW((StgAP_STACK *)c); - break; - case CONSTR: case CONSTR_1_0: case CONSTR_0_1: case CONSTR_2_0: case CONSTR_1_1: case CONSTR_0_2: - case FUN: case FUN_1_0: case FUN_0_1: case FUN_2_0: case FUN_1_1: case FUN_0_2: - case BLACKHOLE: case SE_BLACKHOLE: case CAF_BLACKHOLE: case SE_CAF_BLACKHOLE: - size = sizeW_fromITBL(info); - break; - case IND_PERM: case IND_OLDGEN_PERM: - size = sizeofW(StgInd); - break; - /* 'Ingore' cases */ @@ -214,15 +153,10 @@ processHeapClosureForDead( StgClosure *c ) // rate. case IND: case IND_OLDGEN: - size = sizeofW(StgInd); + // Found a dead closure: record its size + LDV_recordDead(c, size); return size; - case EVACUATED: - // The size of the evacuated closure is currently stored in - // the LDV field. See SET_EVACUAEE_FOR_LDV() in - // includes/StgLdvProf.h. - return LDVW(c); - /* Error case */ @@ -255,10 +189,6 @@ processHeapClosureForDead( StgClosure *c ) barf("Invalid object in processHeapClosureForDead(): %d", info->type); return 0; } - - // Found a dead closure: record its size - LDV_recordDead(c, size); - return size; } /* -------------------------------------------------------------------------- diff --git a/ghc/rts/LdvProfile.h b/ghc/rts/LdvProfile.h index 9a607801f9..d85b95cd6a 100644 --- a/ghc/rts/LdvProfile.h +++ b/ghc/rts/LdvProfile.h @@ -24,7 +24,7 @@ extern void LdvCensusKillAll ( void ); // Invoked when: // 1) Hp is incremented and exceeds HpLim (in Updates.hc). // 2) copypart() is called (in GC.c). -#define FILL_SLOP(from, howManyBackwards) \ +#define LDV_FILL_SLOP(from, howManyBackwards) \ if (era > 0) { \ int i; \ for (i = 0;i < (howManyBackwards); i++) \ diff --git a/ghc/rts/Linker.c b/ghc/rts/Linker.c index 87fda47c61..fe9d98bc60 100644 --- a/ghc/rts/Linker.c +++ b/ghc/rts/Linker.c @@ -26,6 +26,7 @@ #include "RtsUtils.h" #include "Schedule.h" #include "Storage.h" +#include "Sparks.h" #ifdef HAVE_SYS_TYPES_H #include <sys/types.h> @@ -527,6 +528,7 @@ typedef struct _RtsSymbolVal { SymX(newTVarzh_fast) \ SymX(atomicModifyMutVarzh_fast) \ SymX(newPinnedByteArrayzh_fast) \ + SymX(newSpark) \ SymX(orIntegerzh_fast) \ SymX(performGC) \ SymX(performMajorGC) \ diff --git a/ghc/rts/ProfHeap.c b/ghc/rts/ProfHeap.c index c7ed1d0bc2..a50f2f0ac7 100644 --- a/ghc/rts/ProfHeap.c +++ b/ghc/rts/ProfHeap.c @@ -870,13 +870,13 @@ heapCensusChain( Census *census, bdescr *bd ) case THUNK_1_1: case THUNK_0_2: case THUNK_2_0: - size = sizeofW(StgHeader) + stg_max(MIN_UPD_SIZE,2); + size = sizeofW(StgThunkHeader) + 2; break; case THUNK_1_0: case THUNK_0_1: case THUNK_SELECTOR: - size = sizeofW(StgHeader) + stg_max(MIN_UPD_SIZE,1); + size = sizeofW(StgThunkHeader) + 1; break; case CONSTR: @@ -902,7 +902,7 @@ heapCensusChain( Census *census, bdescr *bd ) case CONSTR_2_0: size = sizeW_fromITBL(info); break; - + case IND: // Special case/Delicate Hack: INDs don't normally // appear, since we're doing this heap census right diff --git a/ghc/rts/RetainerProfile.c b/ghc/rts/RetainerProfile.c index 2f93cbf29a..80708fa002 100644 --- a/ghc/rts/RetainerProfile.c +++ b/ghc/rts/RetainerProfile.c @@ -2062,99 +2062,7 @@ sanityCheckHeapClosure( StgClosure *c ) // debugBelch("sanityCheckHeapClosure) S: flip = %d, c = %p(%d), rs = %p\n", flip, c, get_itbl(c)->type, RSET(c)); } - info = get_itbl(c); - switch (info->type) { - case TSO: - return tso_sizeW((StgTSO *)c); - - case THUNK: - case THUNK_1_0: - case THUNK_0_1: - case THUNK_2_0: - case THUNK_1_1: - case THUNK_0_2: - return stg_max(sizeW_fromITBL(info), sizeofW(StgHeader) + MIN_UPD_SIZE); - - case MVAR: - return sizeofW(StgMVar); - - case MUT_ARR_PTRS_CLEAN: - case MUT_ARR_PTRS_DIRTY: - case MUT_ARR_PTRS_FROZEN: - case MUT_ARR_PTRS_FROZEN0: - return mut_arr_ptrs_sizeW((StgMutArrPtrs *)c); - - case AP: - case PAP: - return pap_sizeW((StgPAP *)c); - - case AP: - return ap_stack_sizeW((StgAP_STACK *)c); - - case ARR_WORDS: - return arr_words_sizeW((StgArrWords *)c); - - case CONSTR: - case CONSTR_1_0: - case CONSTR_0_1: - case CONSTR_2_0: - case CONSTR_1_1: - case CONSTR_0_2: - case FUN: - case FUN_1_0: - case FUN_0_1: - case FUN_2_0: - case FUN_1_1: - case FUN_0_2: - case WEAK: - case MUT_VAR_CLEAN: - case MUT_VAR_DIRTY: - case CAF_BLACKHOLE: - case BLACKHOLE: - case SE_BLACKHOLE: - case SE_CAF_BLACKHOLE: - case IND_PERM: - case IND_OLDGEN: - case IND_OLDGEN_PERM: - case BCO: - case STABLE_NAME: - return sizeW_fromITBL(info); - - case THUNK_SELECTOR: - return sizeofW(StgHeader) + MIN_UPD_SIZE; - - /* - Error case - */ - case IND_STATIC: - case CONSTR_STATIC: - case FUN_STATIC: - case THUNK_STATIC: - case CONSTR_INTLIKE: - case CONSTR_CHARLIKE: - case CONSTR_NOCAF_STATIC: - case UPDATE_FRAME: - case CATCH_FRAME: - case STOP_FRAME: - case RET_DYN: - case RET_BCO: - case RET_SMALL: - case RET_VEC_SMALL: - case RET_BIG: - case RET_VEC_BIG: - case IND: - case BLOCKED_FETCH: - case FETCH_ME: - case FETCH_ME_BQ: - case RBH: - case REMOTE_REF: - case EVACUATED: - case INVALID_OBJECT: - default: - barf("Invalid object in sanityCheckHeapClosure(): %d", - get_itbl(c)->type); - return 0; - } + return closure_sizeW(c); } static nat diff --git a/ghc/rts/Sanity.c b/ghc/rts/Sanity.c index 9c0ed2bb84..9ee630c4e5 100644 --- a/ghc/rts/Sanity.c +++ b/ghc/rts/Sanity.c @@ -1,6 +1,6 @@ /* ----------------------------------------------------------------------------- * - * (c) The GHC Team, 1998-2001 + * (c) The GHC Team, 1998-2006 * * Sanity checking code for the heap and stack. * @@ -280,7 +280,7 @@ checkClosure( StgClosure* p ) for (i = 0; i < info->layout.payload.ptrs; i++) { ASSERT(LOOKS_LIKE_CLOSURE_PTR(((StgThunk *)p)->payload[i])); } - return stg_max(thunk_sizeW_fromITBL(info), sizeofW(StgHeader)+MIN_UPD_SIZE); + return thunk_sizeW_fromITBL(info); } case FUN: @@ -359,7 +359,7 @@ checkClosure( StgClosure* p ) */ StgInd *ind = (StgInd *)p; ASSERT(LOOKS_LIKE_CLOSURE_PTR(ind->indirectee)); - return sizeofW(StgHeader) + MIN_UPD_SIZE; + return sizeofW(StgInd); } case RET_BCO: @@ -560,7 +560,7 @@ checkHeap(bdescr *bd) while (p < bd->free) { nat size = checkClosure((StgClosure *)p); /* This is the smallest size of closure that can live in the heap */ - ASSERT( size >= MIN_NONUPD_SIZE + sizeofW(StgHeader) ); + ASSERT( size >= MIN_PAYLOAD_SIZE + sizeofW(StgHeader) ); p += size; /* skip over slop */ @@ -590,11 +590,11 @@ checkHeapChunk(StgPtr start, StgPtr end) size = sizeofW(StgFetchMe); } else if (get_itbl((StgClosure*)p)->type == IND) { *(p+2) = 0x0000ee11; /* mark slop in IND as garbage */ - size = MIN_UPD_SIZE; + size = sizeofW(StgInd); } else { size = checkClosure((StgClosure *)p); /* This is the smallest size of closure that can live in the heap. */ - ASSERT( size >= MIN_NONUPD_SIZE + sizeofW(StgHeader) ); + ASSERT( size >= MIN_PAYLOAD_SIZE + sizeofW(StgHeader) ); } } } @@ -609,7 +609,7 @@ checkHeapChunk(StgPtr start, StgPtr end) ASSERT(LOOKS_LIKE_INFO_PTR((void*)*p)); size = checkClosure((StgClosure *)p); /* This is the smallest size of closure that can live in the heap. */ - ASSERT( size >= MIN_NONUPD_SIZE + sizeofW(StgHeader) ); + ASSERT( size >= MIN_PAYLOAD_SIZE + sizeofW(StgHeader) ); } } #endif diff --git a/ghc/rts/Schedule.c b/ghc/rts/Schedule.c index d72b4597c9..ea41563896 100644 --- a/ghc/rts/Schedule.c +++ b/ghc/rts/Schedule.c @@ -3771,7 +3771,7 @@ raiseAsync_(Capability *cap, StgTSO *tso, StgClosure *exception, // we've got an exception to raise, so let's pass it to the // handler in this frame. // - raise = (StgThunk *)allocateLocal(cap,sizeofW(StgThunk)+MIN_UPD_SIZE); + raise = (StgThunk *)allocateLocal(cap,sizeofW(StgThunk)+1); TICK_ALLOC_SE_THK(1,0); SET_HDR(raise,&stg_raise_info,cf->header.prof.ccs); raise->payload[0] = exception; @@ -3904,7 +3904,7 @@ raiseExceptionHelper (StgRegTable *reg, StgTSO *tso, StgClosure *exception) // thunks which are currently under evaluataion. // - // + // OLD COMMENT (we don't have MIN_UPD_SIZE now): // LDV profiling: stg_raise_info has THUNK as its closure // type. Since a THUNK takes at least MIN_UPD_SIZE words in its // payload, MIN_UPD_SIZE is more approprate than 1. It seems that @@ -3932,7 +3932,7 @@ raiseExceptionHelper (StgRegTable *reg, StgTSO *tso, StgClosure *exception) // Only create raise_closure if we need to. if (raise_closure == NULL) { raise_closure = - (StgThunk *)allocateLocal(cap,sizeofW(StgThunk)+MIN_UPD_SIZE); + (StgThunk *)allocateLocal(cap,sizeofW(StgThunk)+1); SET_HDR(raise_closure, &stg_raise_info, CCCS); raise_closure->payload[0] = exception; } diff --git a/ghc/rts/Sparks.c b/ghc/rts/Sparks.c index 12af296380..5d9a4700dc 100644 --- a/ghc/rts/Sparks.c +++ b/ghc/rts/Sparks.c @@ -220,8 +220,18 @@ newSpark (StgRegTable *reg, StgClosure *p) return 1; } +#else + +StgInt +newSpark (StgRegTable *reg, StgClosure *p) +{ + /* nothing */ + return 1; +} + #endif /* PARALLEL_HASKELL || SMP */ + /* ----------------------------------------------------------------------------- * * GRAN & PARALLEL_HASKELL stuff beyond here. diff --git a/ghc/rts/Sparks.h b/ghc/rts/Sparks.h index 089b3f4597..5c6aff7050 100644 --- a/ghc/rts/Sparks.h +++ b/ghc/rts/Sparks.h @@ -9,12 +9,15 @@ #ifndef SPARKS_H #define SPARKS_H +#if !defined(GRAN) +StgInt newSpark (StgRegTable *reg, StgClosure *p); +#endif + #if defined(PARALLEL_HASKELL) || defined(SMP) StgClosure * findSpark (Capability *cap); void initSparkPools (void); void markSparkQueue (evac_fn evac); void createSparkThread (Capability *cap, StgClosure *p); -StgInt newSpark (StgRegTable *reg, StgClosure *p); INLINE_HEADER void discardSparks (StgSparkPool *pool); INLINE_HEADER nat sparkPoolSize (StgSparkPool *pool); diff --git a/ghc/rts/Updates.h b/ghc/rts/Updates.h index 0ec619a74c..c5af055410 100644 --- a/ghc/rts/Updates.h +++ b/ghc/rts/Updates.h @@ -191,62 +191,69 @@ extern void awakenBlockedQueue(StgBlockingQueueElement *q, StgClosure *node); * the slop in one of the threads would have a disastrous effect on * the other (seen in the wild!). */ -#if !defined(DEBUG) || defined(SMP) - -#define DEBUG_FILL_SLOP(p) /* nothing */ - -#else /* DEBUG */ - #ifdef CMINUSMINUS -#define DEBUG_FILL_SLOP(p) \ +#define FILL_SLOP(p) \ W_ inf; \ W_ sz; \ W_ i; \ inf = %GET_STD_INFO(p); \ - if (%INFO_TYPE(inf) != HALF_W_(THUNK_SELECTOR)) { \ - if (%INFO_TYPE(inf) != HALF_W_(BLACKHOLE)) { \ + if (%INFO_TYPE(inf) != HALF_W_(THUNK_SELECTOR) \ + && %INFO_TYPE(inf) != HALF_W_(BLACKHOLE) \ + && %INFO_TYPE(inf) != HALF_W_(CAF_BLACKHOLE)) { \ if (%INFO_TYPE(inf) == HALF_W_(AP_STACK)) { \ - sz = StgAP_STACK_size(p) + BYTES_TO_WDS(SIZEOF_StgAP_STACK_NoHdr); \ + sz = StgAP_STACK_size(p) + BYTES_TO_WDS(SIZEOF_StgAP_STACK_NoThunkHdr); \ } else { \ - sz = TO_W_(%INFO_PTRS(inf)) + TO_W_(%INFO_NPTRS(inf)); \ + if (%INFO_TYPE(inf) == HALF_W_(AP)) { \ + sz = TO_W_(StgAP_n_args(p)) + BYTES_TO_WDS(SIZEOF_StgAP_NoThunkHdr); \ + } else { \ + sz = TO_W_(%INFO_PTRS(inf)) + TO_W_(%INFO_NPTRS(inf)); \ + } \ } \ - i = 1; /* skip over indirectee */ \ + i = 0; \ for: \ if (i < sz) { \ StgThunk_payload(p,i) = 0; \ i = i + 1; \ goto for; \ } \ - } } + } #else /* !CMINUSMINUS */ INLINE_HEADER void -DEBUG_FILL_SLOP(StgClosure *p) +FILL_SLOP(StgClosure *p) { StgInfoTable *inf = get_itbl(p); nat i, sz; switch (inf->type) { case BLACKHOLE: + case CAF_BLACKHOLE: case THUNK_SELECTOR: return; + case AP: + sz = ((StgAP *)p)->n_args + sizeofW(StgAP) - sizeofW(StgThunkHeader); + break; case AP_STACK: - sz = ((StgAP_STACK *)p)->size + sizeofW(StgAP_STACK) - sizeofW(StgHeader); + sz = ((StgAP_STACK *)p)->size + sizeofW(StgAP_STACK) - sizeofW(StgThunkHeader); break; default: sz = inf->layout.payload.ptrs + inf->layout.payload.nptrs; break; } - // start at one to skip over the indirectee - for (i = 1; i < sz; i++) { + for (i = 0; i < sz; i++) { ((StgThunk *)p)->payload[i] = 0; } } #endif /* CMINUSMINUS */ -#endif /* DEBUG */ + +#if !defined(DEBUG) || defined(SMP) +#define DEBUG_FILL_SLOP(p) /* do nothing */ +#else +#define DEBUG_FILL_SLOP(p) FILL_SLOP(p) +#endif /* We have two versions of this macro (sadly), one for use in C-- code, * and the other for C. diff --git a/mk/config.mk.in b/mk/config.mk.in index 85625e36de..931c4f5244 100644 --- a/mk/config.mk.in +++ b/mk/config.mk.in @@ -311,8 +311,10 @@ endif # # thr : threaded # thr_p : threaded profiled +# s : smp # debug : debugging (compile with -g for the C compiler, and -DDEBUG) # debug_p : debugging profiled +# debug_s : debugging smp # debug_u : debugging unregisterised # thr_debug : debugging threaded # thr_debug_p : debugging threaded profiled @@ -320,7 +322,7 @@ endif ifeq "$(BootingFromHc)" "YES" GhcRTSWays= else -GhcRTSWays=thr thr_p debug thr_debug +GhcRTSWays=thr thr_p s debug debug_s thr_debug endif # Option flags to pass to GHC when it's compiling modules in @@ -1048,10 +1050,6 @@ WAY_t_HC_OPTS= -ticky WAY_u_NAME=unregisterized (using portable C only) WAY_u_HC_OPTS=-unreg -# Way `s': -WAY_s_NAME=threads (for SMP) -WAY_s_HC_OPTS=-smp -optc-DTHREADED_RTS - # Way `mp': WAY_mp_NAME=parallel WAY_mp_HC_OPTS=-parallel @@ -1072,6 +1070,10 @@ WAY_thr_HC_OPTS=-optc-DTHREADED_RTS WAY_thr_p_NAME=threaded profiled WAY_thr_p_HC_OPTS=-optc-DTHREADED_RTS -prof +# Way `s': +WAY_s_NAME=threads (for SMP) +WAY_s_HC_OPTS=-optc-DSMP -optc-DTHREADED_RTS + # Way 'debug': WAY_debug_NAME=debug WAY_debug_HC_OPTS=-optc-DDEBUG @@ -1086,7 +1088,7 @@ WAY_debug_u_HC_OPTS=-optc-DDEBUG -unreg # Way 'debug_s': WAY_debug_s_NAME=debug SMP -WAY_debug_s_HC_OPTS=-optc-DDEBUG -optc-DTHREADED_RTS -smp +WAY_debug_s_HC_OPTS=-optc-DDEBUG -optc-DTHREADED_RTS -optc-DSMP # Way 'thr_debug': WAY_thr_debug_NAME=threaded |