X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcodeGen%2FCgClosure.lhs;h=1b80beaf4090ae2e5de8cecb39e3ad7ca5acffb1;hb=783e505e2d884f94d30ec8074e590507f2561c49;hp=0348f8f28262a1508cd54db0c1aefc164faef43d;hpb=d01e768b927a536f36f8727f634a5e6e48e914e3;p=ghc-hetmet.git diff --git a/ghc/compiler/codeGen/CgClosure.lhs b/ghc/compiler/codeGen/CgClosure.lhs index 0348f8f..1b80bea 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.28 1999/04/23 09:51:24 simonm Exp $ +% $Id: CgClosure.lhs,v 1.39 2000/01/13 14:33:58 hwloidl 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,19 @@ 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, + pprCLabel ) 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 +56,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 +270,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 +299,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 @@ -321,7 +326,12 @@ closureCodeBody binder_info closure_info cc all_args body -- arg_regs = case entry_conv of DirectEntry lbl arity regs -> regs - other -> panic "closureCodeBody:arg_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" num_arg_regs = length arg_regs @@ -338,13 +348,15 @@ 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` setRealAndVirtualSp sp_all_args `thenC` - argSatisfactionCheck closure_info `thenC` + argSatisfactionCheck closure_info arg_regs `thenC` -- OK, so there are enough args. Now we need to stuff as -- many of them in registers as the fast-entry code @@ -355,8 +367,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 +381,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 +412,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 +446,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 @@ -494,24 +522,24 @@ relative offset of this word tells how many words of arguments are expected. \begin{code} -argSatisfactionCheck :: ClosureInfo -> Code +argSatisfactionCheck :: ClosureInfo -> [MagicId] {-GRAN-} -> Code -argSatisfactionCheck closure_info +argSatisfactionCheck closure_info arg_regs = nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points -> - let - emit_gran_macros = opt_GranMacros - in +-- let +-- emit_gran_macros = opt_GranMacros +-- in -- HWL ngo' ngoq: -- absC (CMacroStmt GRAN_FETCH []) `thenC` -- forceHeapCheck [] node_points (absC AbsCNop) `thenC` - (if emit_gran_macros - then if node_points - then fetchAndReschedule [] node_points - else yield [] node_points - else absC AbsCNop) `thenC` + --(if opt_GranMacros + -- then if node_points + -- then fetchAndReschedule arg_regs node_points + -- else yield arg_regs node_points + -- else absC AbsCNop) `thenC` getSpRelOffset 0 `thenFC` \ (SpRel sp) -> let @@ -539,26 +567,23 @@ 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 -> - let - emit_gran_macros = opt_GranMacros - in - -- HWL: insert macros for GrAnSim; 2 versions depending on liveness of node - -- (we prefer fetchAndReschedule-style context switches to yield ones) - (if emit_gran_macros - then if node_points - then fetchAndReschedule [] node_points - else yield [] node_points - else absC AbsCNop) `thenC` + -- 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` -- 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 @@ -569,22 +594,19 @@ 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 - emit_gran_macros = opt_GranMacros - in -- HWL chu' ngoq: - (if emit_gran_macros - then yield arg_regs node_points - else absC AbsCNop) `thenC` + (if opt_GranMacros + then yield arg_regs node_points + 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 @@ -600,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} %************************************************************************