X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcodeGen%2FCgClosure.lhs;h=2a6d941ee5e42933c5513d063e520e1ff14f90ad;hb=7370adc00c9de2092c2323c7a8e20902dc4bbe41;hp=5fba8c0dff9fc1651573321cd52cbd5064c02f63;hpb=47eef4b5780f0a5b5a37847097842daebd0f9285;p=ghc-hetmet.git diff --git a/ghc/compiler/codeGen/CgClosure.lhs b/ghc/compiler/codeGen/CgClosure.lhs index 5fba8c0..2a6d941 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.43 2000/11/06 08:15:21 simonpj Exp $ +% $Id: CgClosure.lhs,v 1.58 2002/09/13 15:02:27 simonpj Exp $ % \section[CgClosure]{Code generation for closures} @@ -46,14 +46,15 @@ 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 +import FastString import Name ( nameOccName ) import OccName ( occNameFS ) @@ -73,37 +74,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 - = -- LAY OUT THE OBJECT +cgTopRhsClosure id ccs binder_info srt args body lf_info + = + -- LAY OUT THE OBJECT + getSRTInfo srt `thenFC` \ srt_info -> let - closure_info = layOutStaticNoFVClosure name lf_info + name = idName id + 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) @@ -113,10 +108,7 @@ cgTopRhsClosure id ccs binder_info args body lf_info ) `thenC` returnFC (id, cg_id_info) - where - name = idName id - closure_label = mkClosureLabel name - cg_id_info = stableAmodeIdInfo id (CLbl closure_label PtrRep) lf_info + \end{code} %******************************************************** @@ -146,7 +138,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 @@ -165,13 +158,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 -- @@ -190,21 +184,21 @@ cgRhsClosure binder cc binder_info fvs args body lf_info then fvs `minusList` [binder] else fvs in - mapFCs getCAddrModeAndInfo reduced_fvs `thenFC` \ amodes_and_info -> + mapFCs getCAddrModeAndInfo reduced_fvs `thenFC` \ fvs_w_amodes_and_info -> + getSRTInfo srt `thenFC` \ srt_info -> let - fvs_w_amodes_and_info = reduced_fvs `zip` amodes_and_info - closure_info :: ClosureInfo - bind_details :: [((Id, (CAddrMode, LambdaFormInfo)), VirtualHeapOffset)] + 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 + bind_fv ((id, _, lf_info), offset) = bindNewToNode id offset lf_info - amodes_w_offsets = [(amode,offset) | ((_, (amode,_)), offset) <- bind_details] + amodes_w_offsets = [(amode,offset) | ((_,amode,_), offset) <- bind_details] - get_kind (id, amode_and_info) = idPrimRep id + get_kind (id, _, _) = idPrimRep id in -- BUILD ITS INFO TABLE AND CODE forkClosureBody ( @@ -268,13 +262,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 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 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 @@ -321,16 +324,9 @@ closureCodeBody binder_info closure_info cc all_args body -- arg_regs = case entry_conv of DirectEntry lbl arity regs -> regs - other -> trace ("*** closureCodeBody:arg_regs " ++ (pprHWL entry_conv) ++ "(HWL ignored; no args passed in regs)") [] - - pprHWL :: EntryConvention -> String - pprHWL (ViaNode) = "ViaNode" - pprHWL (StdEntry cl) = "StdEntry" - pprHWL (DirectEntry cl i l) = "DirectEntry" + 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 @@ -343,7 +339,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` @@ -375,39 +371,40 @@ 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 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 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)), --- CString (_PK_ (show_wrapper_arg_kinds wrapper_maybe)) +-- CString (mkFastString (show_wrapper_name wrapper_maybe)), +-- CString (mkFastString (show_wrapper_arg_kinds wrapper_maybe)) -- 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 ( @@ -416,7 +413,7 @@ closureCodeBody binder_info closure_info cc all_args body 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 -> + 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) @@ -433,6 +430,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 (FSLIT("TICK_ENT_STATIC_FUN_STD"), FSLIT("TICK_ENT_STATIC_FUN_DIRECT")) + else (FSLIT("TICK_ENT_DYN_FUN_STD"), FSLIT("TICK_ENT_DYN_FUN_DIRECT")) + stg_arity = length all_args lf_info = closureLFInfo closure_info @@ -448,7 +450,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} @@ -475,25 +477,25 @@ 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") [] + costCentresC FSLIT("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] + 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 SLIT("ENTER_CCS_FSUB") [] - else costCentresC SLIT("ENTER_CCS_CAF") c_ccs + then costCentresC FSLIT("ENTER_CCS_FSUB") [] + else costCentresC FSLIT("ENTER_CCS_CAF") c_ccs else panic "enterCostCentreCode" @@ -594,11 +596,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 ( @@ -648,7 +653,7 @@ setupUpdate closure_info code code else case (closureUpdReqd closure_info, isStaticClosure closure_info) of - (False,False) -> profCtrC SLIT("TICK_UPDF_OMITTED") [] `thenC` + (False,False) -> profCtrC FSLIT("TICK_UPDF_OMITTED") [] `thenC` code (False,True ) -> (if opt_DoTickyProfiling then @@ -656,16 +661,16 @@ setupUpdate closure_info code 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` + 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 SLIT("TICK_UPD_CAF_BH_UPDATABLE") [mkCString cl_name] `thenC` + profCtrC FSLIT("TICK_UPD_CAF_BH_UPDATABLE") [mkCString cl_name] `thenC` pushUpdateFrame update_closure code where - cl_name :: FAST_STRING + cl_name :: FastString cl_name = (occNameFS . nameOccName . closureName) closure_info link_caf :: (ClosureInfo -> ClosureInfo) -- function yielding BH closure_info @@ -740,6 +745,3 @@ chooseDynCostCentres ccs args fvs body in (use_cc, blame_cc) \end{code} - - -