X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcodeGen%2FCgClosure.lhs;h=dc5e9eae35389226b22618d0c2b62a8b2701fd1a;hb=423d477bfecd490de1449c59325c8776f91d7aac;hp=6e77dc78532cffd7291ca0224acf281f82766a37;hpb=553e90d9a32ee1b1809430f260c401cc4169c6c7;p=ghc-hetmet.git diff --git a/ghc/compiler/codeGen/CgClosure.lhs b/ghc/compiler/codeGen/CgClosure.lhs index 6e77dc7..dc5e9ea 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.62 2003/11/17 14:23:31 simonmar Exp $ +% $Id: CgClosure.lhs,v 1.63 2004/08/13 13:05:54 simonmar Exp $ % \section[CgClosure]{Code generation for closures} @@ -13,6 +13,7 @@ with {\em closures} on the RHSs of let(rec)s. See also module CgClosure ( cgTopRhsClosure, cgStdRhsClosure, cgRhsClosure, + emitBlackHoleCode, ) where #include "HsVersions.h" @@ -21,37 +22,38 @@ import {-# SOURCE #-} CgExpr ( cgExpr ) import CgMonad import CgBindery -import CgUpdate ( pushUpdateFrame ) import CgHeapery -import CgStackery -import CgUsages +import CgStackery ( mkVirtStkOffsets, pushUpdateFrame, getVirtSp, + setRealAndVirtualSp ) +import CgProf ( chooseDynCostCentres, ldvEnter, enterCostCentre, + costCentreFrom ) +import CgTicky +import CgParallel ( granYield, granFetchAndReschedule ) +import CgInfoTbls ( emitClosureCodeAndInfoTable, getSRTInfo ) +import CgCallConv ( assignCallRegs, mkArgDescr ) +import CgUtils ( emitDataLits, addIdReps, cmmRegOffW, + emitRtsCallWithVols ) import ClosureInfo -- lots and lots of stuff - -import AbsCUtils ( getAmodeRep, mkAbstractCs ) -import AbsCSyn -import CLabel - +import SMRep ( CgRep, cgRepSizeW, argMachRep, fixedHdrSize, WordOff, + idCgRep ) +import MachOp ( MachHint(..) ) +import Cmm +import CmmUtils ( CmmStmts, mkStmts, oneStmt, plusStmts, noStmts, + mkLblExpr ) +import CLabel ( mkRtsDataLabel, mkClosureLabel, mkRednCountsLabel, + mkSlowEntryLabel, mkIndStaticInfoLabel ) import StgSyn -import CmdLineOpts ( opt_GranMacros, opt_SccProfilingOn, opt_DoTickyProfiling ) +import CmdLineOpts ( opt_DoTickyProfiling ) import CostCentre -import Id ( Id, idName, idType, idPrimRep ) -import Name ( Name, isInternalName ) +import Id ( Id, idName, idType ) +import Name ( Name ) import Module ( Module, pprModule ) import ListSetOps ( minusList ) -import PrimRep ( PrimRep(..), getPrimRepSize ) -import Util ( isIn, splitAtList ) -import CmdLineOpts ( opt_SccProfilingOn ) +import Util ( isIn, mapAccumL, zipWithEqual ) +import BasicTypes ( TopLevelFlag(..) ) +import Constants ( oFFSET_StgInd_indirectee, wORD_SIZE ) import Outputable import FastString - -import Name ( nameOccName ) -import OccName ( occNameFS ) - --- Turgid imports for showTypeCategory -import PrelNames -import TcType ( Type, isDictTy, tcSplitTyConApp_maybe, tcSplitFunTy_maybe ) -import TyCon ( isPrimTyCon, isTupleTyCon, isEnumerationTyCon, maybeTyConSingleCon ) -import Maybe \end{code} %******************************************************** @@ -68,45 +70,29 @@ cgTopRhsClosure :: Id -> CostCentreStack -- Optional cost centre annotation -> StgBinderInfo -> SRT + -> UpdateFlag -> [Id] -- Args -> StgExpr - -> LambdaFormInfo -> FCode (Id, CgIdInfo) -cgTopRhsClosure id ccs binder_info srt args body lf_info - = - let - name = idName id - in - -- LAY OUT THE OBJECT - getSRTInfo name srt `thenFC` \ srt_info -> - moduleName `thenFC` \ mod_name -> - let - name = idName id - descr = closureDescription mod_name name - closure_info = layOutStaticNoFVClosure id lf_info srt_info descr +cgTopRhsClosure id ccs binder_info srt upd_flag args body = do + { -- LAY OUT THE OBJECT + let name = idName id + ; lf_info <- mkClosureLFInfo id TopLevel [] upd_flag args + ; srt_info <- getSRTInfo name srt + ; mod_name <- moduleName + ; let descr = closureDescription mod_name name + closure_info = mkClosureInfo True id lf_info 0 0 srt_info descr closure_label = mkClosureLabel name - cg_id_info = stableAmodeIdInfo id (CLbl closure_label PtrRep) lf_info - in - - -- BUILD THE OBJECT (IF NECESSARY) - ( - ({- if staticClosureRequired name binder_info lf_info - then -} - absC (mkStaticClosure closure_label closure_info ccs [] True) - {- else - nopC -} - ) - `thenC` - - -- GENERATE THE INFO TABLE (IF NECESSARY) - forkClosureBody (closureCodeBody binder_info closure_info - ccs args body) + cg_id_info = stableIdInfo id (mkLblExpr closure_label) lf_info + closure_rep = mkStaticClosureFields closure_info ccs True [] - ) `thenC` - - returnFC (id, cg_id_info) + -- BUILD THE OBJECT, AND GENERATE INFO TABLE (IF NECESSARY) + ; emitDataLits closure_label closure_rep + ; forkClosureBody (closureCodeBody binder_info closure_info + ccs args body) + ; returnFC (id, cg_id_info) } \end{code} %******************************************************** @@ -129,29 +115,26 @@ cgStdRhsClosure -> [StgArg] -- payload -> FCode (Id, CgIdInfo) -cgStdRhsClosure binder cc binder_info fvs args body lf_info payload - -- AHA! A STANDARD-FORM THUNK - = ( - -- LAY OUT THE OBJECT - getArgAmodes payload `thenFC` \ amodes -> - moduleName `thenFC` \ mod_name -> - let - descr = closureDescription mod_name (idName binder) - - (closure_info, amodes_w_offsets) - = layOutDynClosure binder getAmodeRep amodes lf_info NoC_SRT descr - -- No SRT for a standard-form closure - - (use_cc, blame_cc) = chooseDynCostCentres cc args fvs body - in +cgStdRhsClosure bndr cc bndr_info fvs args body lf_info payload + = do -- AHA! A STANDARD-FORM THUNK + { -- LAY OUT THE OBJECT + amodes <- getArgAmodes payload + ; mod_name <- moduleName + ; let (tot_wds, ptr_wds, amodes_w_offsets) = mkVirtHeapOffsets amodes + + descr = closureDescription mod_name (idName bndr) + closure_info = mkClosureInfo False -- Not static + bndr lf_info tot_wds ptr_wds + NoC_SRT -- No SRT for a std-form closure + descr + + ; (use_cc, blame_cc) <- chooseDynCostCentres cc args body -- BUILD THE OBJECT - allocDynClosure closure_info use_cc blame_cc amodes_w_offsets - ) - `thenFC` \ heap_offset -> + ; heap_offset <- allocDynClosure closure_info use_cc blame_cc amodes_w_offsets -- RETURN - returnFC (binder, heapIdInfo binder heap_offset lf_info) + ; returnFC (bndr, heapIdInfo bndr heap_offset lf_info) } \end{code} Here's the general case. @@ -162,15 +145,13 @@ cgRhsClosure :: Id -> StgBinderInfo -> SRT -> [Id] -- Free vars + -> UpdateFlag -> [Id] -- Args -> StgExpr - -> LambdaFormInfo -> FCode (Id, CgIdInfo) -cgRhsClosure binder cc binder_info srt fvs args body lf_info - = ( - -- LAY OUT THE OBJECT - -- +cgRhsClosure bndr cc bndr_info srt fvs upd_flag args body = do + { -- LAY OUT THE OBJECT -- If the binder is itself a free variable, then don't store -- it in the closure. Instead, just bind it to Node on entry. -- NB we can be sure that Node will point to it, because we @@ -179,62 +160,63 @@ cgRhsClosure binder cc binder_info srt fvs args body lf_info -- stored in the closure itself, so it will make sure that -- Node points to it... let - is_elem = isIn "cgRhsClosure" - - binder_is_a_fv = binder `is_elem` fvs - reduced_fvs = if binder_is_a_fv - then fvs `minusList` [binder] - else fvs - - name = idName binder - in - - mapFCs getCAddrModeAndInfo reduced_fvs `thenFC` \ fvs_w_amodes_and_info -> - getSRTInfo name srt `thenFC` \ srt_info -> - moduleName `thenFC` \ mod_name -> - let - descr = closureDescription mod_name (idName binder) - - closure_info :: ClosureInfo - bind_details :: [((Id, CAddrMode, LambdaFormInfo), VirtualHeapOffset)] - - (closure_info, bind_details) - = layOutDynClosure binder get_kind - fvs_w_amodes_and_info lf_info srt_info descr - - bind_fv ((id, _, lf_info), offset) = bindNewToNode id offset lf_info - - amodes_w_offsets = [(amode,offset) | ((_,amode,_), offset) <- bind_details] - - get_kind (id, _, _) = idPrimRep id - in + name = idName bndr + is_elem = isIn "cgRhsClosure" + bndr_is_a_fv = bndr `is_elem` fvs + reduced_fvs | bndr_is_a_fv = fvs `minusList` [bndr] + | otherwise = fvs + + ; lf_info <- mkClosureLFInfo bndr NotTopLevel fvs upd_flag args + ; fv_infos <- mapFCs getCgIdInfo reduced_fvs + ; srt_info <- getSRTInfo name srt + ; mod_name <- moduleName + ; let bind_details :: [(CgIdInfo, VirtualHpOffset)] + (tot_wds, ptr_wds, bind_details) = mkVirtHeapOffsets (map add_rep fv_infos) + add_rep info = (cgIdInfoArgRep info, info) + + descr = closureDescription mod_name name + closure_info = mkClosureInfo False -- Not static + bndr lf_info tot_wds ptr_wds + srt_info descr -- BUILD ITS INFO TABLE AND CODE - forkClosureBody ( - -- Bind the fvs - mapCs bind_fv bind_details `thenC` + ; forkClosureBody (do + { -- Bind the fvs + let bind_fv (info, offset) + = bindNewToNode (cgIdInfoId info) offset (cgIdInfoLF info) + ; mapCs bind_fv bind_details -- Bind the binder itself, if it is a free var - (if binder_is_a_fv then - bindNewToReg binder node lf_info - else - nopC) `thenC` - + ; whenC bndr_is_a_fv (bindNewToReg bndr nodeReg lf_info) + -- Compile the body - closureCodeBody binder_info closure_info cc args body - ) `thenC` + ; closureCodeBody bndr_info closure_info cc args body }) -- BUILD THE OBJECT - let - (use_cc, blame_cc) = chooseDynCostCentres cc args fvs body - in - allocDynClosure closure_info use_cc blame_cc amodes_w_offsets - ) `thenFC` \ heap_offset -> + ; let + to_amode (info, offset) = do { amode <- idInfoToAmode info + ; return (amode, offset) } + ; (use_cc, blame_cc) <- chooseDynCostCentres cc args body + ; amodes_w_offsets <- mapFCs to_amode bind_details + ; heap_offset <- allocDynClosure closure_info use_cc blame_cc amodes_w_offsets -- RETURN - returnFC (binder, heapIdInfo binder heap_offset lf_info) + ; returnFC (bndr, heapIdInfo bndr heap_offset lf_info) } + + +mkClosureLFInfo :: Id -- The binder + -> TopLevelFlag -- True of top level + -> [Id] -- Free vars + -> UpdateFlag -- Update flag + -> [Id] -- Args + -> FCode LambdaFormInfo +mkClosureLFInfo bndr top fvs upd_flag args + | null args = return (mkLFThunk (idType bndr) top fvs upd_flag) + | otherwise = do { arg_descr <- mkArgDescr (idName bndr) args + ; return (mkLFReEntrant top fvs args arg_descr) } \end{code} + %************************************************************************ %* * \subsection[code-for-closures]{The code for closures} @@ -253,32 +235,23 @@ closureCodeBody :: StgBinderInfo There are two main cases for the code for closures. If there are {\em no arguments}, then the closure is a thunk, and not in normal form. So it should set up an update frame (if it is shared). +NB: Thunks cannot have a primitive type! \begin{code} -closureCodeBody binder_info closure_info cc [] body - = -- thunks cannot have a primitive type! - getAbsC body_code `thenFC` \ body_absC -> - - absC (CClosureInfoAndCode closure_info body_absC) - where - is_box = case body of { StgApp fun [] -> True; _ -> False } - - ticky_ent_lit = if (isStaticClosure closure_info) - then FSLIT("TICK_ENT_STATIC_THK") - else FSLIT("TICK_ENT_DYN_THK") - - body_code = profCtrC ticky_ent_lit [] `thenC` - -- node always points when profiling, so this is ok: - ldvEnter `thenC` - thunkWrapper closure_info ( - -- We only enter cc after setting up update so - -- that cc of enclosing scope will be recorded - -- in update frame CAF/DICT functions will be - -- subsumed by this enclosing cc - enterCostCentreCode closure_info cc IsThunk is_box `thenC` - cgExpr body - ) - +closureCodeBody binder_info cl_info cc [] body = do + { body_absC <- getCgStmts $ do + { tickyEnterThunk cl_info + ; ldvEnter (CmmReg nodeReg) -- NB: Node always points when profiling + ; thunkWrapper cl_info $ do + -- We only enter cc after setting up update so + -- that cc of enclosing scope will be recorded + -- in update frame CAF/DICT functions will be + -- subsumed by this enclosing cc + { enterCostCentre cl_info cc body + ; cgExpr body } + } + + ; emitClosureCodeAndInfoTable cl_info [] body_absC } \end{code} If there is /at least one argument/, then this closure is in @@ -289,105 +262,60 @@ argSatisfactionCheck (by calling fetchAndReschedule). There info if Node points to closure is available. -- HWL \begin{code} -closureCodeBody binder_info closure_info cc all_args body - = let arg_reps = map idPrimRep all_args in - - getEntryConvention name lf_info arg_reps `thenFC` \ entry_conv -> - - let - -- Arg mapping for the entry point; as many args as poss in - -- registers; the rest on the stack - -- arg_regs are the registers used for arg passing - -- stk_args are the args which are passed on the stack - -- - -- Args passed on the stack are not tagged. - -- - arg_regs = case entry_conv of - DirectEntry lbl arity regs -> regs - _ -> panic "closureCodeBody" - in - - -- If this function doesn't have a specialised ArgDescr, we need - -- to generate the function's arg bitmap, slow-entry code, and - -- register-save code for the heap-check failure - -- - (case closureFunInfo closure_info of - Just (_, ArgGen slow_lbl liveness) -> - absC (maybeLargeBitmap liveness) `thenC` - absC (mkSlowEntryCode name slow_lbl arg_regs arg_reps) `thenC` - returnFC (mkRegSaveCode arg_regs arg_reps) - - other -> returnFC AbsCNop - ) - `thenFC` \ reg_save_code -> - - -- get the current virtual Sp (it might not be zero, eg. if we're - -- compiling a let-no-escape). - getVirtSp `thenFC` \vSp -> - - let - (reg_args, stk_args) = splitAtList arg_regs all_args - - (sp_stk_args, stk_offsets) - = mkVirtStkOffsets vSp idPrimRep stk_args - - entry_code = do - mod_name <- moduleName - profCtrC FSLIT("TICK_CTR") [ - CLbl ticky_ctr_label DataPtrRep, - mkCString (mkFastString (ppr_for_ticky_name mod_name name)), - mkIntCLit stg_arity, -- total # of args - mkIntCLit sp_stk_args, -- # passed on stk - mkCString (mkFastString (map (showTypeCategory . idType) all_args)) - ] - let prof = - profCtrC ticky_ent_lit [ - CLbl ticky_ctr_label DataPtrRep - ] - - -- Bind args to regs/stack as appropriate, and - -- record expected position of sps. - bindArgsToRegs reg_args arg_regs - mapCs bindNewToStack stk_offsets - setRealAndVirtualSp sp_stk_args - - -- Enter the closures cc, if required - enterCostCentreCode closure_info cc IsFunction False - - -- Do the business - funWrapper closure_info arg_regs reg_save_code - (prof >> cgExpr body) - in - - setTickyCtrLabel ticky_ctr_label ( - - forkAbsC entry_code `thenFC` \ entry_abs_c -> - moduleName `thenFC` \ mod_name -> - - -- Now construct the info table - absC (CClosureInfoAndCode closure_info entry_abs_c) - ) - where - ticky_ctr_label = mkRednCountsLabel name - - ticky_ent_lit = - if (isStaticClosure closure_info) - then FSLIT("TICK_ENT_STATIC_FUN_DIRECT") - else FSLIT("TICK_ENT_DYN_FUN_DIRECT") - - stg_arity = length all_args - lf_info = closureLFInfo closure_info - - -- Manufacture labels - name = closureName closure_info - - --- When printing the name of a thing in a ticky file, we want to --- give the module name even for *local* things. We print --- just "x (M)" rather that "M.x" to distinguish them from the global kind. -ppr_for_ticky_name mod_name name - | isInternalName name = showSDocDebug (ppr name <+> (parens (ppr mod_name))) - | otherwise = showSDocDebug (ppr name) +closureCodeBody binder_info cl_info cc args body = do + { -- Get the current virtual Sp (it might not be zero, + -- eg. if we're compiling a let-no-escape). + vSp <- getVirtSp + ; let (reg_args, other_args) = assignCallRegs (addIdReps args) + (sp_top, stk_args) = mkVirtStkOffsets vSp other_args + + -- Allocate the global ticky counter + ; let ticky_ctr_lbl = mkRednCountsLabel (closureName cl_info) + ; emitTickyCounter cl_info args sp_top + + -- ...and establish the ticky-counter + -- label for this block + ; setTickyCtrLabel ticky_ctr_lbl $ do + + -- Emit the slow-entry code + { reg_save_code <- mkSlowEntryCode cl_info reg_args + + -- Emit the main entry code + ; blks <- forkProc $ + mkFunEntryCode cl_info cc reg_args stk_args + sp_top reg_save_code body + ; emitClosureCodeAndInfoTable cl_info [] blks + }} + + + +mkFunEntryCode :: ClosureInfo + -> CostCentreStack + -> [(Id,GlobalReg)] -- Args in regs + -> [(Id,VirtualSpOffset)] -- Args on stack + -> VirtualSpOffset -- Last allocated word on stack + -> CmmStmts -- Register-save code in case of GC + -> StgExpr + -> Code +-- The main entry code for the closure +mkFunEntryCode cl_info cc reg_args stk_args sp_top reg_save_code body = do + { -- Bind args to regs/stack as appropriate, + -- and record expected position of sps + ; bindArgsToRegs reg_args + ; bindArgsToStack stk_args + ; setRealAndVirtualSp sp_top + + -- Enter the cost-centre, if required + -- ToDo: It's not clear why this is outside the funWrapper, + -- but the tickyEnterFun is inside. Perhaps we can put + -- them together? + ; enterCostCentre cl_info cc body + + -- Do the business + ; funWrapper cl_info reg_args reg_save_code $ do + { tickyEnterFun cl_info + ; cgExpr body } + } \end{code} The "slow entry" code for a function. This entry point takes its @@ -402,84 +330,45 @@ The slow entry point is used in two places: (b) returning from a heap-check failure \begin{code} -mkSlowEntryCode :: Name -> CLabel -> [MagicId] -> [PrimRep] -> AbstractC -mkSlowEntryCode name lbl regs reps - = CCodeBlock lbl ( - mkAbstractCs [assts, stk_adj, jump] - ) +mkSlowEntryCode :: ClosureInfo -> [(Id,GlobalReg)] -> FCode CmmStmts +-- If this function doesn't have a specialised ArgDescr, we need +-- to generate the function's arg bitmap, slow-entry code, and +-- register-save code for the heap-check failure +-- Here, we emit the slow-entry code, and +-- return the register-save assignments +mkSlowEntryCode cl_info reg_args + | Just (_, ArgGen _) <- closureFunInfo cl_info + = do { emitSimpleProc slow_lbl (emitStmts load_stmts) + ; return save_stmts } + | otherwise = return noStmts where - stk_offsets = scanl (\off rep -> off - getPrimRepSize rep) 0 reps - - assts = mkAbstractCs (zipWith3 mk_asst reps regs stk_offsets) - mk_asst rep reg offset = CAssign (CReg reg) (CVal (spRel 0 offset) rep) - - stk_adj = CAssign (CReg Sp) (CAddr (spRel 0 stk_final_offset)) - stk_final_offset = head (drop (length regs) stk_offsets) - - jump = CJump (CLbl (mkEntryLabel name) CodePtrRep) - -mkRegSaveCode :: [MagicId] -> [PrimRep] -> AbstractC -mkRegSaveCode regs reps - = mkAbstractCs [stk_adj, assts] - where - stk_adj = CAssign (CReg Sp) (CAddr (spRel 0 (negate stk_final_offset))) - - stk_final_offset = head (drop (length regs) stk_offsets) - stk_offsets = scanl (\off rep -> off - getPrimRepSize rep) 0 reps - - assts = mkAbstractCs (zipWith3 mk_asst reps regs stk_offsets) - mk_asst rep reg offset = CAssign (CVal (spRel 0 offset) rep) (CReg reg) + name = closureName cl_info + slow_lbl = mkSlowEntryLabel name + + load_stmts = mkStmts load_assts `plusStmts` mkStmts [stk_adj_pop, jump_to_entry] + save_stmts = oneStmt stk_adj_push `plusStmts` mkStmts save_assts + + reps_w_regs :: [(CgRep,GlobalReg)] + reps_w_regs = [(idCgRep id, reg) | (id,reg) <- reverse reg_args] + (final_stk_offset, stk_offsets) + = mapAccumL (\off (rep,_) -> (off + cgRepSizeW rep, off)) + 0 reps_w_regs + + load_assts = zipWithEqual "mk_load" mk_load reps_w_regs stk_offsets + mk_load (rep,reg) offset = CmmAssign (CmmGlobal reg) + (CmmLoad (cmmRegOffW spReg offset) + (argMachRep rep)) + + save_assts = zipWithEqual "mk_save" mk_save reps_w_regs stk_offsets + mk_save (rep,reg) offset = ASSERT( argMachRep rep == globalRegRep reg ) + CmmStore (cmmRegOffW spReg offset) + (CmmReg (CmmGlobal reg)) + + stk_adj_pop = CmmAssign spReg (cmmRegOffW spReg final_stk_offset) + stk_adj_push = CmmAssign spReg (cmmRegOffW spReg (- final_stk_offset)) + jump_to_entry = CmmJump (mkLblExpr (enterIdLabel name)) [] \end{code} -For lexically scoped profiling we have to load the cost centre from -the closure entered, if the costs are not supposed to be inherited. -This is done immediately on entering the fast entry point. - -Load current cost centre from closure, if not inherited. -Node is guaranteed to point to it, if profiling and not inherited. - -\begin{code} -data IsThunk = IsThunk | IsFunction -- Bool-like, local --- #ifdef DEBUG - deriving Eq --- #endif - -enterCostCentreCode - :: ClosureInfo -> CostCentreStack - -> IsThunk - -> Bool -- is_box: this closure is a special box introduced by SCCfinal - -> Code - -enterCostCentreCode closure_info ccs is_thunk is_box - = if not opt_SccProfilingOn then - nopC - else - ASSERT2(not (noCCSAttached ccs), ppr (closureName closure_info) <+> ppr ccs) - - if isSubsumedCCS ccs then - ASSERT(isToplevClosure closure_info) - ASSERT(is_thunk == IsFunction) - costCentresC FSLIT("ENTER_CCS_FSUB") [] - - else if isDerivedFromCurrentCCS ccs then - if re_entrant && not is_box - then costCentresC FSLIT("ENTER_CCS_FCL") [CReg node] - else costCentresC FSLIT("ENTER_CCS_TCL") [CReg node] - - else if isCafCCS ccs then - ASSERT(isToplevClosure closure_info) - ASSERT(is_thunk == IsThunk) - -- might be a PAP, in which case we want to subsume costs - if re_entrant - then costCentresC FSLIT("ENTER_CCS_FSUB") [] - else costCentresC FSLIT("ENTER_CCS_CAF") c_ccs - - else panic "enterCostCentreCode" - - where - c_ccs = [mkCCostCentreStack ccs] - re_entrant = closureReEntrant closure_info -\end{code} %************************************************************************ %* * @@ -489,62 +378,42 @@ enterCostCentreCode closure_info ccs is_thunk is_box \begin{code} thunkWrapper:: ClosureInfo -> Code -> Code -thunkWrapper closure_info thunk_code - = -- Stack and heap overflow checks - nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points -> +thunkWrapper closure_info thunk_code = do + { let node_points = nodeMustPointToIt (closureLFInfo closure_info) -- HWL: insert macros for GrAnSim; 2 versions depending on liveness of node -- (we prefer fetchAndReschedule-style context switches to yield ones) - (if opt_GranMacros - then if node_points - then fetchAndReschedule [] node_points - else yield [] node_points - else absC AbsCNop) `thenC` - - let closure_lbl - | node_points = Nothing - | otherwise = Just (closureLabelFromCI closure_info) - in - - -- stack and/or heap checks - thunkChecks closure_lbl ( - - -- Overwrite with black hole if necessary - blackHoleIt closure_info node_points `thenC` - - setupUpdate closure_info ( -- setupUpdate *encloses* the rest - - -- Finally, do the business - thunk_code - )) + ; if node_points + then granFetchAndReschedule [] node_points + else granYield [] node_points + + -- Stack and/or heap checks + ; thunkEntryChecks closure_info $ do + { -- Overwrite with black hole if necessary + whenC (blackHoleOnEntry closure_info && node_points) + (blackHoleIt closure_info) + ; setupUpdate closure_info thunk_code } + -- setupUpdate *encloses* the thunk_code + } funWrapper :: ClosureInfo -- Closure whose code body this is - -> [MagicId] -- List of argument registers (if any) - -> AbstractC -- reg saves for the heap check failure + -> [(Id,GlobalReg)] -- List of argument registers (if any) + -> CmmStmts -- reg saves for the heap check failure -> Code -- Body of function being compiled -> Code -funWrapper closure_info arg_regs reg_save_code fun_body - = -- Stack overflow check - nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points -> - - -- enter for Ldv profiling - (if node_points then ldvEnter else nopC) `thenC` +funWrapper closure_info arg_regs reg_save_code fun_body = do + { let node_points = nodeMustPointToIt (closureLFInfo closure_info) - (if opt_GranMacros - then yield arg_regs node_points - else absC AbsCNop) `thenC` + -- Enter for Ldv profiling + ; whenC node_points (ldvEnter (CmmReg nodeReg)) - let closure_lbl - | node_points = Nothing - | otherwise = Just (closureLabelFromCI closure_info) - in + -- GranSim yeild poin + ; granYield arg_regs node_points - -- heap and/or stack checks - funEntryChecks closure_lbl reg_save_code ( - - -- Finally, do the business - fun_body - ) + -- Heap and/or stack checks wrap the function body + ; funEntryChecks closure_info reg_save_code + fun_body + } \end{code} @@ -556,78 +425,150 @@ funWrapper closure_info arg_regs reg_save_code fun_body \begin{code} -blackHoleIt :: ClosureInfo -> Bool -> Code -- Only called for closures with no args - -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 args - else - CMacroStmt UPD_BH_UPDATABLE args) - else +blackHoleIt :: ClosureInfo -> Code +-- Only called for closures with no args +-- Node points to the closure +blackHoleIt closure_info = emitBlackHoleCode (closureSingleEntry closure_info) + +emitBlackHoleCode :: Bool -> Code +emitBlackHoleCode is_single_entry + | eager_blackholing = do + tickyBlackHole (not is_single_entry) + stmtC (CmmStore (CmmReg nodeReg) (CmmLit (CmmLabel bh_lbl))) + | otherwise = nopC + where + bh_lbl | is_single_entry = mkRtsDataLabel SLIT("stg_SE_BLACKHOLE_info") + | otherwise = mkRtsDataLabel SLIT("stg_BLACKHOLE_info") + + -- If we wanted to do eager blackholing with slop filling, + -- we'd need to do it at the *end* of a basic block, otherwise + -- we overwrite the free variables in the thunk that we still + -- need. We have a patch for this from Andy Cheadle, but not + -- incorporated yet. --SDM [6/2004] + -- + -- Profiling needs slop filling (to support LDV profiling), so + -- currently eager blackholing doesn't work with profiling. + -- + -- TICKY_TICKY needs EAGER_BLACKHOLING to verify no double-entries of + -- single-entry thunks. + eager_blackholing + | opt_DoTickyProfiling = True + | otherwise = False + \end{code} \begin{code} setupUpdate :: ClosureInfo -> Code -> Code -- Only called for closures with no args -- Nota Bene: this function does not change Node (even if it's a CAF), -- so that the cost centre in the original closure can still be - -- extracted by a subsequent ENTER_CC_TCL - --- I've tidied up the code for this function, but it should still do the same as --- it did before (modulo ticky stuff). KSW 1999-04. + -- extracted by a subsequent enterCostCentre setupUpdate closure_info code - = if closureReEntrant closure_info - then - code - else - case (closureUpdReqd closure_info, isStaticClosure closure_info) of - (False,False) -> profCtrC FSLIT("TICK_UPDF_OMITTED") [] `thenC` - code - (False,True ) -> (if opt_DoTickyProfiling - then - -- blackhole the SE CAF - link_caf seCafBlackHoleClosureInfo `thenFC` \ _ -> nopC - else - nopC) `thenC` - profCtrC FSLIT("TICK_UPD_CAF_BH_SINGLE_ENTRY") [mkCString cl_name] `thenC` - profCtrC FSLIT("TICK_UPDF_OMITTED") [] `thenC` - code - (True ,False) -> pushUpdateFrame (CReg node) code - (True ,True ) -> -- blackhole the (updatable) CAF: - link_caf cafBlackHoleClosureInfo `thenFC` \ update_closure -> - profCtrC FSLIT("TICK_UPD_CAF_BH_UPDATABLE") [mkCString cl_name] `thenC` - pushUpdateFrame update_closure code - where - cl_name :: FastString - cl_name = (occNameFS . nameOccName . closureName) closure_info - - link_caf :: (ClosureInfo -> ClosureInfo) -- function yielding BH closure_info - -> FCode CAddrMode -- Returns amode for closure to be updated - link_caf bhCI - = -- To update a CAF we must allocate a black hole, link the CAF onto the - -- CAF list, then update the CAF to point to the fresh black hole. - -- This function returns the address of the black hole, so it can be - -- updated with the new value when available. - - -- Alloc black hole specifying CC_HDR(Node) as the cost centre - let - use_cc = CMacroExpr PtrRep CCS_HDR [nodeReg] - blame_cc = use_cc - in - allocDynClosure (bhCI closure_info) use_cc blame_cc [] `thenFC` \ heap_offset -> - getHpRelOffset heap_offset `thenFC` \ hp_rel -> - let amode = CAddr hp_rel - in - absC (CMacroStmt UPD_CAF [CReg node, amode]) `thenC` - returnFC amode + | closureReEntrant closure_info + = code + + | not (isStaticClosure closure_info) + = if closureUpdReqd closure_info + then do { tickyPushUpdateFrame; pushUpdateFrame (CmmReg nodeReg) code } + else do { tickyUpdateFrameOmitted; code } + + | otherwise -- A static closure + = do { tickyUpdateBhCaf closure_info + + ; if closureUpdReqd closure_info + then do -- Blackhole the (updatable) CAF: + { upd_closure <- link_caf closure_info True + ; pushUpdateFrame upd_closure code } + else do + { -- No update reqd, you'd think we don't need to + -- black-hole it. But when ticky-ticky is on, we + -- black-hole it regardless, to catch errors in which + -- an allegedly single-entry closure is entered twice + -- + -- We discard the pointer returned by link_caf, because + -- we don't push an update frame + whenC opt_DoTickyProfiling -- Blackhole even a SE CAF + (link_caf closure_info False >> nopC) + ; tickyUpdateFrameOmitted + ; code } + } + + +----------------------------------------------------------------------------- +-- Entering a CAF +-- +-- When a CAF is first entered, it creates a black hole in the heap, +-- and updates itself with an indirection to this new black hole. +-- +-- We update the CAF with an indirection to a newly-allocated black +-- hole in the heap. We also set the blocking queue on the newly +-- allocated black hole to be empty. +-- +-- Why do we make a black hole in the heap when we enter a CAF? +-- +-- - for a generational garbage collector, which needs a fast +-- test for whether an updatee is in an old generation or not +-- +-- - for the parallel system, which can implement updates more +-- easily if the updatee is always in the heap. (allegedly). +-- +-- When debugging, we maintain a separate CAF list so we can tell when +-- a CAF has been garbage collected. + +-- newCAF must be called before the itbl ptr is overwritten, since +-- newCAF records the old itbl ptr in order to do CAF reverting +-- (which Hugs needs to do in order that combined mode works right.) +-- + +-- ToDo [Feb 04] This entire link_caf nonsense could all be moved +-- into the "newCAF" RTS procedure, which we call anyway, including +-- the allocation of the black-hole indirection closure. +-- That way, code size would fall, the CAF-handling code would +-- be closer together, and the compiler wouldn't need to know +-- about off_indirectee etc. + +link_caf :: ClosureInfo + -> Bool -- True <=> updatable, False <=> single-entry + -> FCode CmmExpr -- Returns amode for closure to be updated +-- To update a CAF we must allocate a black hole, link the CAF onto the +-- CAF list, then update the CAF to point to the fresh black hole. +-- This function returns the address of the black hole, so it can be +-- updated with the new value when available. The reason for all of this +-- is that we only want to update dynamic heap objects, not static ones, +-- so that generational GC is easier. +link_caf cl_info is_upd = do + { -- Alloc black hole specifying CC_HDR(Node) as the cost centre + ; let use_cc = costCentreFrom (CmmReg nodeReg) + blame_cc = use_cc + ; hp_offset <- allocDynClosure bh_cl_info use_cc blame_cc [] + ; hp_rel <- getHpRelOffset hp_offset + + -- Call the RTS function newCAF to add the CAF to the CafList + -- so that the garbage collector can find them + -- This must be done *before* the info table pointer is overwritten, + -- because the old info table ptr is needed for reversion + ; emitRtsCallWithVols SLIT("newCAF") [(CmmReg nodeReg,PtrHint)] [node] + -- node is live, so save it. + + -- Overwrite the closure with a (static) indirection + -- to the newly-allocated black hole + ; stmtsC [ CmmStore (cmmRegOffW nodeReg off_indirectee) hp_rel + , CmmStore (CmmReg nodeReg) ind_static_info ] + + ; returnFC hp_rel } + where + bh_cl_info :: ClosureInfo + bh_cl_info | is_upd = cafBlackHoleClosureInfo cl_info + | otherwise = seCafBlackHoleClosureInfo cl_info + + ind_static_info :: CmmExpr + ind_static_info = mkLblExpr mkIndStaticInfoLabel + + off_indirectee :: WordOff + off_indirectee = fixedHdrSize + oFFSET_StgInd_indirectee*wORD_SIZE \end{code} + %************************************************************************ %* * \subsection[CgClosure-Description]{Profiling Closure Description.} @@ -635,99 +576,17 @@ setupUpdate closure_info code %************************************************************************ For "global" data constructors the description is simply occurrence -name of the data constructor itself (see \ref{CgConTbls-info-tables}). - -Otherwise it is determind by @closureDescription@ from the let -binding information. +name of the data constructor itself. Otherwise it is determined by +@closureDescription@ from the let binding information. \begin{code} closureDescription :: Module -- Module -> Name -- Id of closure binding -> String - -- Not called for StgRhsCon which have global info tables built in -- CgConTbls.lhs with a description generated from the data constructor - closureDescription mod_name name - = showSDoc ( - hcat [char '<', - pprModule mod_name, - char '.', - ppr name, - char '>']) + = showSDoc (hcat [char '<', pprModule mod_name, + char '.', ppr name, char '>']) \end{code} -\begin{code} -chooseDynCostCentres ccs args fvs body - = let - use_cc -- cost-centre we record in the object - = if currentOrSubsumedCCS ccs - then CReg CurCostCentre - else mkCCostCentreStack ccs - - blame_cc -- cost-centre on whom we blame the allocation - = case (args, fvs, body) of - ([], _, StgApp fun [{-no args-}]) - -> mkCCostCentreStack overheadCCS - _ -> use_cc - - -- if it's an utterly trivial RHS, then it must be - -- one introduced by boxHigherOrderArgs for profiling, - -- so we charge it to "OVERHEAD". - - -- This looks like a HACK to me --SDM - in - (use_cc, blame_cc) -\end{code} - - -\begin{code} -showTypeCategory :: Type -> Char - {- - {C,I,F,D} char, int, float, double - T tuple - S other single-constructor type - {c,i,f,d} unboxed ditto - t *unpacked* tuple - s *unpacked" single-cons... - - v void# - a primitive array - - E enumeration type - + dictionary, unless it's a ... - L List - > function - M other (multi-constructor) data-con type - . other type - - reserved for others to mark as "uninteresting" - -} -showTypeCategory ty - = if isDictTy ty - then '+' - else - case tcSplitTyConApp_maybe ty of - Nothing -> if isJust (tcSplitFunTy_maybe ty) - then '>' - else '.' - - Just (tycon, _) -> - let utc = getUnique tycon in - if utc == charDataConKey then 'C' - else if utc == intDataConKey then 'I' - else if utc == floatDataConKey then 'F' - else if utc == doubleDataConKey then 'D' - else if utc == smallIntegerDataConKey || - utc == largeIntegerDataConKey then 'J' - else if utc == charPrimTyConKey then 'c' - else if (utc == intPrimTyConKey || utc == wordPrimTyConKey - || utc == addrPrimTyConKey) then 'i' - else if utc == floatPrimTyConKey then 'f' - else if utc == doublePrimTyConKey then 'd' - else if isPrimTyCon tycon {- array, we hope -} then 'A' -- Bogus - else if isEnumerationTyCon tycon then 'E' - else if isTupleTyCon tycon then 'T' - else if isJust (maybeTyConSingleCon tycon) then 'S' - else if utc == listTyConKey then 'L' - else 'M' -- oh, well... -\end{code}