X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcodeGen%2FCgClosure.lhs;h=e7d70e4fa56d7fadc1af55e8f07bf26969a4d386;hb=e3b49acc7f2bdb14bfb59886877a0c639ea71c71;hp=32f442e4d5c7e0b6d1efeee29d51ec65b919e28d;hpb=6e4feb0ecf12e7890f5298ca55f715eed3411095;p=ghc-hetmet.git diff --git a/ghc/compiler/codeGen/CgClosure.lhs b/ghc/compiler/codeGen/CgClosure.lhs index 32f442e..e7d70e4f 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.47 2001/08/21 10:00:22 simonpj Exp $ +% $Id: CgClosure.lhs,v 1.56 2002/03/14 15:27:17 simonpj Exp $ % \section[CgClosure]{Code generation for closures} @@ -46,12 +46,12 @@ import ClosureInfo -- lots and lots of stuff import CmdLineOpts ( opt_GranMacros, opt_SccProfilingOn, opt_DoTickyProfiling ) import CostCentre import Id ( Id, idName, idType, idPrimRep ) -import Name ( Name, isLocalName ) +import Name ( Name, isInternalName ) import Module ( Module, pprModule ) import ListSetOps ( minusList ) import PrimRep ( PrimRep(..) ) import PprType ( showTypeCategory ) -import Util ( isIn ) +import Util ( isIn, splitAtList ) import CmdLineOpts ( opt_SccProfilingOn ) import Outputable @@ -73,41 +73,31 @@ They should have no free variables. cgTopRhsClosure :: Id -> CostCentreStack -- Optional cost centre annotation -> StgBinderInfo + -> SRT -> [Id] -- Args -> StgExpr -> LambdaFormInfo -> FCode (Id, CgIdInfo) -cgTopRhsClosure id ccs binder_info args body lf_info +cgTopRhsClosure id ccs binder_info srt args body lf_info = -- LAY OUT THE OBJECT + getSRTInfo srt `thenFC` \ srt_info -> let name = idName id - closure_info = layOutStaticNoFVClosure name lf_info - closure_label = mkClosureLabel name + closure_info = layOutStaticNoFVClosure name lf_info srt_info + 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 -} - (if opt_SccProfilingOn - then - absC (CStaticClosure - closure_label -- Labelled with the name on lhs of defn - closure_info - (mkCCostCentreStack ccs) - []) -- No fields - else - absC (CStaticClosure - closure_label -- Labelled with the name on lhs of defn - closure_info - (panic "absent cc") - []) -- No fields - ) - - {- else + ( + ({- if staticClosureRequired name binder_info lf_info + then -} + absC (mkStaticClosure closure_info ccs [] True) + {- else nopC -} + ) `thenC` -- GENERATE THE INFO TABLE (IF NECESSARY) @@ -147,7 +137,8 @@ cgStdRhsClosure binder cc binder_info fvs args body lf_info payload getArgAmodes payload `thenFC` \ amodes -> let (closure_info, amodes_w_offsets) - = layOutDynClosure (idName binder) getAmodeRep amodes lf_info + = layOutDynClosure (idName binder) getAmodeRep amodes lf_info NoC_SRT + -- No SRT for a standard-form closure (use_cc, blame_cc) = chooseDynCostCentres cc args fvs body in @@ -166,13 +157,14 @@ Here's the general case. cgRhsClosure :: Id -> CostCentreStack -- Optional cost centre annotation -> StgBinderInfo + -> SRT -> [Id] -- Free vars -> [Id] -- Args -> StgExpr -> LambdaFormInfo -> FCode (Id, CgIdInfo) -cgRhsClosure binder cc binder_info fvs args body lf_info +cgRhsClosure binder cc binder_info srt fvs args body lf_info = ( -- LAY OUT THE OBJECT -- @@ -192,12 +184,14 @@ cgRhsClosure binder cc binder_info fvs args body lf_info else fvs in mapFCs getCAddrModeAndInfo reduced_fvs `thenFC` \ fvs_w_amodes_and_info -> + getSRTInfo srt `thenFC` \ srt_info -> let closure_info :: ClosureInfo bind_details :: [((Id, CAddrMode, LambdaFormInfo), VirtualHeapOffset)] (closure_info, bind_details) - = layOutDynClosure (idName binder) get_kind fvs_w_amodes_and_info lf_info + = layOutDynClosure (idName binder) get_kind + fvs_w_amodes_and_info lf_info srt_info bind_fv ((id, _, lf_info), offset) = bindNewToNode id offset lf_info @@ -267,13 +261,22 @@ closureCodeBody binder_info closure_info cc [] body is_box = case body of { StgApp fun [] -> True; _ -> False } - body_code = profCtrC SLIT("TICK_ENT_THK") [] `thenC` + ticky_ent_lit = if (isStaticClosure closure_info) + then SLIT("TICK_ENT_STATIC_THK") + else SLIT("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 body_label ( - -- 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 + -- 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) + cgExpr body + ) + \end{code} If there is {\em at least one argument}, then this closure is in @@ -322,9 +325,7 @@ closureCodeBody binder_info closure_info cc all_args body DirectEntry lbl arity regs -> regs other -> [] -- "(HWL ignored; no args passed in regs)" - num_arg_regs = length arg_regs - - (reg_args, stk_args) = splitAt num_arg_regs all_args + (reg_args, stk_args) = splitAtList arg_regs all_args (sp_stk_args, stk_offsets, stk_tags) = mkTaggedVirtStkOffsets vSp idPrimRep stk_args @@ -337,7 +338,7 @@ 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") [ + = profCtrC slow_ticky_ent_lit [ CLbl ticky_ctr_label DataPtrRep ] `thenC` @@ -369,19 +370,19 @@ closureCodeBody binder_info closure_info cc all_args body -- see argSatisfactionCheck for new version -- fast_entry_code = forceHeapCheck [] True fast_entry_code' - fast_entry_code - = 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` + fast_entry_code = do + mod_name <- moduleName + 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)) + ] + let prof = + profCtrC fast_ticky_ent_lit [ + CLbl ticky_ctr_label DataPtrRep + ] -- Nuked for now; see comment at end of file -- CString (_PK_ (show_wrapper_name wrapper_maybe)), @@ -390,18 +391,19 @@ closureCodeBody binder_info closure_info cc all_args body -- Bind args to regs/stack as appropriate, and -- record expected position of sps. - bindArgsToRegs reg_args arg_regs `thenC` - mapCs bindNewToStack stk_offsets `thenC` - setRealAndVirtualSp sp_stk_args `thenC` + bindArgsToRegs reg_args arg_regs + mapCs bindNewToStack stk_offsets + setRealAndVirtualSp sp_stk_args -- free up the stack slots containing tags - freeStackSlots (map fst stk_tags) `thenC` + freeStackSlots (map fst stk_tags) -- Enter the closures cc, if required - enterCostCentreCode closure_info cc IsFunction False `thenC` + enterCostCentreCode closure_info cc IsFunction False -- Do the business - funWrapper closure_info arg_regs stk_tags info_label (cgExpr body) + funWrapper closure_info arg_regs stk_tags info_label + (prof >> cgExpr body) in setTickyCtrLabel ticky_ctr_label ( @@ -427,6 +429,11 @@ closureCodeBody binder_info closure_info cc all_args body where ticky_ctr_label = mkRednCountsLabel name + (slow_ticky_ent_lit, fast_ticky_ent_lit) = + if (isStaticClosure closure_info) + then (SLIT("TICK_ENT_STATIC_FUN_STD"), SLIT("TICK_ENT_STATIC_FUN_DIRECT")) + else (SLIT("TICK_ENT_DYN_FUN_STD"), SLIT("TICK_ENT_DYN_FUN_DIRECT")) + stg_arity = length all_args lf_info = closureLFInfo closure_info @@ -442,7 +449,7 @@ closureCodeBody binder_info closure_info cc all_args body -- 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))) + | isInternalName name = showSDocDebug (ppr name <+> (parens (ppr mod_name))) | otherwise = showSDocDebug (ppr name) \end{code} @@ -469,14 +476,14 @@ enterCostCentreCode closure_info ccs is_thunk is_box = if not opt_SccProfilingOn then nopC else - ASSERT(not (noCCSAttached ccs)) + ASSERT2(not (noCCSAttached ccs), ppr (closureName closure_info) <+> ppr ccs) if isSubsumedCCS ccs then ASSERT(isToplevClosure closure_info) ASSERT(is_thunk == IsFunction) costCentresC SLIT("ENTER_CCS_FSUB") [] - else if isCurrentCCS ccs then + else if isDerivedFromCurrentCCS ccs then if re_entrant && not is_box then costCentresC SLIT("ENTER_CCS_FCL") [CReg node] else costCentresC SLIT("ENTER_CCS_TCL") [CReg node] @@ -588,11 +595,14 @@ funWrapper :: ClosureInfo -- Closure whose code body this is -> Code funWrapper closure_info arg_regs stk_tags info_label fun_body = -- Stack overflow check - nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points -> - -- HWL chu' ngoq: + nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points -> + + -- enter for Ldv profiling + (if node_points then ldvEnter else nopC) `thenC` + (if opt_GranMacros then yield arg_regs node_points - else absC AbsCNop) `thenC` + else absC AbsCNop) `thenC` -- heap and/or stack checks fastEntryChecks arg_regs stk_tags info_label node_points ( @@ -734,6 +744,3 @@ chooseDynCostCentres ccs args fvs body in (use_cc, blame_cc) \end{code} - - -