X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcodeGen%2FCgClosure.lhs;h=c40320cc95ec302137d8dffcead1e7f3c699995a;hb=bc467a8b94c61a999ab2d7e71918f3ff549a11b7;hp=6b5ad7bc3fa882d965c9a911f68782c44d240bd5;hpb=36e45f65c9eff04dce5a0b2bad305dc351d09d06;p=ghc-hetmet.git diff --git a/ghc/compiler/codeGen/CgClosure.lhs b/ghc/compiler/codeGen/CgClosure.lhs index 6b5ad7b..c40320c 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.27 1999/04/08 15:46:15 simonm Exp $ +% $Id: CgClosure.lhs,v 1.38 1999/11/11 17:50:49 simonpj Exp $ % \section[CgClosure]{Code generation for closures} @@ -22,7 +22,6 @@ import {-# SOURCE #-} CgExpr ( cgExpr ) import CgMonad import AbsCSyn import StgSyn -import BasicTypes ( TopLevelFlag(..) ) import AbsCUtils ( mkAbstractCs, getAmodeRep ) import CgBindery ( getCAddrMode, getArgAmodes, @@ -36,18 +35,18 @@ import CgHeapery ( allocDynClosure, fetchAndReschedule, yield, -- HWL fastEntryChecks, thunkChecks ) -import CgStackery ( adjustRealSp, mkTaggedVirtStkOffsets, freeStackSlots ) -import CgUsages ( setRealAndVirtualSp, getVirtSp, +import CgStackery ( mkTaggedVirtStkOffsets, freeStackSlots ) +import CgUsages ( adjustSpAndHp, setRealAndVirtualSp, getVirtSp, getSpRelOffset, getHpRelOffset ) import CLabel ( CLabel, mkClosureLabel, mkFastEntryLabel, - mkRednCountsLabel, mkStdEntryLabel + mkRednCountsLabel, mkInfoTableLabel ) import ClosureInfo -- lots and lots of stuff -import CmdLineOpts ( opt_GranMacros, opt_SccProfilingOn ) +import CmdLineOpts ( opt_GranMacros, opt_SccProfilingOn, opt_DoTickyProfiling ) import CostCentre import Id ( Id, idName, idType, idPrimRep ) -import Name ( Name ) +import Name ( Name, isLocalName ) import Module ( Module, pprModule ) import ListSetOps ( minusList ) import PrimRep ( PrimRep(..) ) @@ -56,6 +55,9 @@ import Util ( isIn ) import CmdLineOpts ( opt_SccProfilingOn ) import Outputable +import Name ( nameOccName ) +import OccName ( occNameFS ) + getWrapperArgTypeCategories = panic "CgClosure.getWrapperArgTypeCategories (ToDo)" \end{code} @@ -267,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` @@ -295,6 +298,7 @@ closureCodeBody binder_info closure_info cc all_args body -- get the current virtual Sp (it might not be zero, eg. if we're -- compiling a let-no-escape). getVirtSp `thenFC` \vSp -> + let -- Figure out what is needed and what isn't @@ -338,7 +342,9 @@ closureCodeBody binder_info closure_info cc all_args body --slow_entry_code = forceHeapCheck [] True slow_entry_code' slow_entry_code - = profCtrC SLIT("TICK_ENT_FUN_STD") [] `thenC` + = profCtrC SLIT("TICK_ENT_FUN_STD") [ + CLbl ticky_ctr_label DataPtrRep + ] `thenC` -- Bind args, and record expected position of stk ptrs mapCs bindNewToStack arg_offsets `thenC` @@ -355,8 +361,9 @@ closureCodeBody binder_info closure_info cc all_args body absC (mkAbstractCs (zipWith assign_to_reg arg_regs stk_amodes)) `thenC` - -- Now adjust real stack pointers - adjustRealSp sp_stk_args `thenC` + -- Now adjust real stack pointers (no need to adjust Hp, + -- but call this function for convenience). + adjustSpAndHp sp_stk_args `thenC` absC (CFallThrough (CLbl fast_label CodePtrRep)) @@ -368,22 +375,23 @@ closureCodeBody binder_info closure_info cc all_args body -- fast_entry_code = forceHeapCheck [] True fast_entry_code' fast_entry_code - = profCtrC SLIT("TICK_ENT_FUN_DIRECT") [ - mkIntCLit stg_arity -- total # of args - - {- CLbl (mkRednCountsLabel name) PtrRep, - CString (_PK_ (showSDoc (ppr name))), - mkIntCLit stg_arity, -- total # of args - mkIntCLit sp_stk_args, -- # passed on stk - CString (_PK_ (map (showTypeCategory . idType) all_args)), - CString SLIT(""), CString SLIT("") - -} + = moduleName `thenFC` \ mod_name -> + profCtrC SLIT("TICK_CTR") [ + CLbl ticky_ctr_label DataPtrRep, + mkCString (_PK_ (ppr_for_ticky_name mod_name name)), + mkIntCLit stg_arity, -- total # of args + mkIntCLit sp_stk_args, -- # passed on stk + mkCString (_PK_ (map (showTypeCategory . idType) all_args)) + ] `thenC` + + profCtrC SLIT("TICK_ENT_FUN_DIRECT") [ + CLbl ticky_ctr_label DataPtrRep + ] `thenC` -- Nuked for now; see comment at end of file -- CString (_PK_ (show_wrapper_name wrapper_maybe)), -- CString (_PK_ (show_wrapper_arg_kinds wrapper_maybe)) - ] `thenC` -- Bind args to regs/stack as appropriate, and -- record expected position of sps. @@ -398,26 +406,32 @@ closureCodeBody binder_info closure_info cc all_args body enterCostCentreCode closure_info cc IsFunction False `thenC` -- Do the business - funWrapper closure_info arg_regs stk_tags slow_label (cgExpr body) + funWrapper closure_info arg_regs stk_tags info_label (cgExpr body) in + + setTickyCtrLabel ticky_ctr_label ( + -- Make a labelled code-block for the slow and fast entry code - forkAbsC (if slow_code_needed then slow_entry_code else absC AbsCNop) + forkAbsC (if slow_code_needed then slow_entry_code else absC AbsCNop) `thenFC` \ slow_abs_c -> - forkAbsC fast_entry_code `thenFC` \ fast_abs_c -> - moduleName `thenFC` \ mod_name -> + forkAbsC fast_entry_code `thenFC` \ fast_abs_c -> + moduleName `thenFC` \ mod_name -> -- Now either construct the info table, or put the fast code in alone -- (We never have slow code without an info table) -- XXX probably need the info table and slow entry code in case of -- a heap check failure. - absC ( - if info_table_needed then - CClosureInfoAndCode closure_info slow_abs_c (Just fast_abs_c) + absC ( + if info_table_needed then + CClosureInfoAndCode closure_info slow_abs_c (Just fast_abs_c) (cl_descr mod_name) - else + else CCodeBlock fast_label fast_abs_c + ) ) where + ticky_ctr_label = mkRednCountsLabel name + stg_arity = length all_args lf_info = closureLFInfo closure_info @@ -426,7 +440,15 @@ closureCodeBody binder_info closure_info cc all_args body -- Manufacture labels name = closureName closure_info fast_label = mkFastEntryLabel name stg_arity - slow_label = mkStdEntryLabel name + info_label = mkInfoTableLabel name + + +-- 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 + | isLocalName name = showSDocDebug (ppr name <+> (parens (ppr mod_name))) + | otherwise = showSDocDebug (ppr name) \end{code} For lexically scoped profiling we have to load the cost centre from @@ -459,11 +481,6 @@ enterCostCentreCode closure_info ccs is_thunk is_box ASSERT(is_thunk == IsFunction) costCentresC SLIT("ENTER_CCS_FSUB") [] - else if isSetCurrentCCS ccs then - ASSERT(not (isToplevClosure closure_info)) - ASSERT(is_thunk == IsFunction) - costCentresC SLIT("ENTER_CCS_TCL") [CReg node] - else if isCurrentCCS ccs then if re_entrant && not is_box then costCentresC SLIT("ENTER_CCS_FCL") [CReg node] @@ -544,7 +561,7 @@ argSatisfactionCheck closure_info \begin{code} thunkWrapper:: ClosureInfo -> CLabel -> Code -> Code -thunkWrapper closure_info label thunk_code +thunkWrapper closure_info lbl thunk_code = -- Stack and heap overflow checks nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points -> @@ -560,10 +577,10 @@ thunkWrapper closure_info label thunk_code else absC AbsCNop) `thenC` -- stack and/or heap checks - thunkChecks label node_points ( + 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 @@ -574,10 +591,10 @@ thunkWrapper closure_info label thunk_code funWrapper :: ClosureInfo -- Closure whose code body this is -> [MagicId] -- List of argument registers (if any) -> [(VirtualSpOffset,Int)] -- tagged stack slots - -> CLabel -- slow entry point for heap check ret. + -> CLabel -- info table for heap check ret. -> Code -- Body of function being compiled -> Code -funWrapper closure_info arg_regs stk_tags slow_label fun_body +funWrapper closure_info arg_regs stk_tags info_label fun_body = -- Stack overflow check nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points -> let @@ -589,7 +606,7 @@ funWrapper closure_info arg_regs stk_tags slow_label fun_body else absC AbsCNop) `thenC` -- heap and/or stack checks - fastEntryChecks arg_regs stk_tags slow_label node_points ( + fastEntryChecks arg_regs stk_tags info_label node_points ( -- Finally, do the business fun_body @@ -605,55 +622,77 @@ funWrapper closure_info arg_regs stk_tags slow_label fun_body \begin{code} -blackHoleIt :: ClosureInfo -> Bool -> Code -- Only called for thunks +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 [CReg node] + CMacroStmt UPD_BH_SINGLE_ENTRY args else - CMacroStmt UPD_BH_UPDATABLE [CReg node]) + CMacroStmt UPD_BH_UPDATABLE args) else nopC \end{code} \begin{code} -setupUpdate :: ClosureInfo -> Code -> Code -- Only called for thunks +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. setupUpdate closure_info code - = if (closureUpdReqd closure_info) then - link_caf_if_needed `thenFC` \ update_closure -> - pushUpdateFrame update_closure code + = if closureReEntrant closure_info + then + code else - profCtrC SLIT("TICK_UPDF_OMITTED") [] `thenC` - code + case (closureUpdReqd closure_info, isStaticClosure closure_info) of + (False,False) -> profCtrC SLIT("TICK_UPDF_OMITTED") [] `thenC` + code + (False,True ) -> (if opt_DoTickyProfiling + then + -- blackhole the SE CAF + link_caf seCafBlackHoleClosureInfo `thenFC` \ _ -> nopC + else + nopC) `thenC` + profCtrC SLIT("TICK_UPD_CAF_BH_SINGLE_ENTRY") [mkCString cl_name] `thenC` + profCtrC SLIT("TICK_UPDF_OMITTED") [] `thenC` + code + (True ,False) -> pushUpdateFrame (CReg node) code + (True ,True ) -> -- blackhole the (updatable) CAF: + link_caf cafBlackHoleClosureInfo `thenFC` \ update_closure -> + profCtrC SLIT("TICK_UPD_CAF_BH_UPDATABLE") [mkCString cl_name] `thenC` + pushUpdateFrame update_closure code where - link_caf_if_needed :: FCode CAddrMode -- Returns amode for closure to be updated - link_caf_if_needed - = if not (isStaticClosure closure_info) then - returnFC (CReg node) - else - - -- First we must allocate a black hole, and link the - -- CAF onto the CAF list - - -- Alloc black hole specifying CC_HDR(Node) as the cost centre - -- Hack Warning: Using a CLitLit to get CAddrMode ! - let - use_cc = CLitLit SLIT("CCS_HDR(R1.p)") PtrRep - blame_cc = use_cc - in - allocDynClosure (blackHoleClosureInfo 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 + cl_name :: FAST_STRING + 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 + -- Hack Warning: Using a CLitLit to get CAddrMode ! + let + use_cc = CLitLit SLIT("CCS_HDR(R1.p)") PtrRep + 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 \end{code} %************************************************************************