%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgClosure.lhs,v 1.35 1999/10/13 16:39:15 simonmar Exp $
+% $Id: CgClosure.lhs,v 1.42 2000/10/24 08:40:09 simonpj Exp $
%
\section[CgClosure]{Code generation for closures}
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(..) )
import Name ( nameOccName )
import OccName ( occNameFS )
-
+import FastTypes ( iBox )
+
getWrapperArgTypeCategories = panic "CgClosure.getWrapperArgTypeCategories (ToDo)"
\end{code}
-- RETURN
returnFC (binder, heapIdInfo binder heap_offset lf_info)
-
- where
- is_std_thunk = isStandardFormThunk lf_info
\end{code}
Here's the general case.
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`
-- Arg mapping for standard (slow) entry point; all args on stack,
-- with tagging.
- (sp_all_args, arg_offsets, arg_tags)
+ (sp_all_args, arg_offsets, _)
= mkTaggedVirtStkOffsets vSp idPrimRep all_args
-- Arg mapping for the fast entry point; as many args as poss in
--
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
--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
-- fast_entry_code = forceHeapCheck [] True fast_entry_code'
fast_entry_code
- = profCtrC SLIT("TICK_CTR") [
+ = moduleName `thenFC` \ mod_name ->
+ profCtrC SLIT("TICK_CTR") [
CLbl ticky_ctr_label DataPtrRep,
- mkCString (_PK_ (showSDocDebug (ppr name))),
+ 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))
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
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
- off = I# sp
+ off = iBox sp
rel_arg = mkIntCLit off
in
ASSERT(off /= 0)
= -- 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
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 (
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}
-- 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 ->
projects / ghc-hetmet.git / blobdiff