X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcodeGen%2FCgClosure.lhs;h=ae028d2a45ba6aea9b7fb01491bdf2d285b13387;hb=9df21db498fed4645fc624e692d70672a84432dc;hp=26c7e51e442eab287f9e35be25f37c86957da036;hpb=4e7d56fde0f44d38bbb9a6fc72cf9c603264899d;p=ghc-hetmet.git diff --git a/ghc/compiler/codeGen/CgClosure.lhs b/ghc/compiler/codeGen/CgClosure.lhs index 26c7e51..ae028d2 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.34 1999/07/14 14:40:28 simonpj Exp $ +% $Id: CgClosure.lhs,v 1.40 2000/07/06 14:08:31 simonmar Exp $ % \section[CgClosure]{Code generation for closures} @@ -46,7 +46,7 @@ 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 ) +import Name ( Name, isLocalName ) import Module ( Module, pprModule ) import ListSetOps ( minusList ) import PrimRep ( PrimRep(..) ) @@ -269,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` @@ -297,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 @@ -323,7 +325,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 @@ -340,13 +347,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 @@ -371,13 +380,18 @@ 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") [ - CLbl (mkRednCountsLabel name) PtrRep, - mkCString (_PK_ (showSDoc (ppr name))), - mkIntCLit stg_arity, -- total # of args - mkIntCLit sp_stk_args, -- # passed on stk - mkCString (_PK_ (map (showTypeCategory . idType) all_args)) - ] `thenC` + = 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)), @@ -399,24 +413,30 @@ closureCodeBody binder_info closure_info cc all_args body -- Do the business 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,6 +446,14 @@ closureCodeBody binder_info closure_info cc all_args body name = closureName closure_info fast_label = mkFastEntryLabel name stg_arity 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 @@ -493,24 +521,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 @@ -542,22 +570,19 @@ 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 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,13 +599,10 @@ funWrapper :: ClosureInfo -- Closure whose code body this is 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 info_label node_points ( @@ -604,10 +626,14 @@ blackHoleIt :: ClosureInfo -> Bool -> Code -- Only called for closures with no a 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} @@ -655,9 +681,8 @@ setupUpdate closure_info code -- 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 + use_cc = CMacroExpr PtrRep CCS_HDR [nodeReg] blame_cc = use_cc in allocDynClosure (bhCI closure_info) use_cc blame_cc [] `thenFC` \ heap_offset ->