%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgClosure.lhs,v 1.21 1998/12/18 17:40:49 simonpj Exp $
+% $Id: CgClosure.lhs,v 1.42 2000/10/24 08:40:09 simonpj Exp $
%
\section[CgClosure]{Code generation for closures}
import CgMonad
import AbsCSyn
import StgSyn
-import BasicTypes ( TopLevelFlag(..) )
import AbsCUtils ( mkAbstractCs, getAmodeRep )
import CgBindery ( getCAddrMode, getArgAmodes,
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
)
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, Module, pprModule )
+import Name ( Name, isLocalName )
+import Module ( Module, pprModule )
import ListSetOps ( minusList )
import PrimRep ( PrimRep(..) )
import PprType ( showTypeCategory )
import CmdLineOpts ( opt_SccProfilingOn )
import Outputable
+import Name ( nameOccName )
+import OccName ( occNameFS )
+import FastTypes ( iBox )
+
getWrapperArgTypeCategories = panic "CgClosure.getWrapperArgTypeCategories (ToDo)"
\end{code}
cgTopRhsClosure :: Id
-> CostCentreStack -- Optional cost centre annotation
-> StgBinderInfo
- -> SRT
-> [Id] -- Args
-> StgExpr
-> LambdaFormInfo
-> FCode (Id, CgIdInfo)
-cgTopRhsClosure id ccs binder_info srt args body lf_info
+cgTopRhsClosure id ccs binder_info args body lf_info
= -- LAY OUT THE OBJECT
let
closure_info = layOutStaticNoFVClosure name lf_info
`thenC`
-- GENERATE THE INFO TABLE (IF NECESSARY)
- forkClosureBody (closureCodeBody binder_info srt closure_info
+ forkClosureBody (closureCodeBody binder_info closure_info
ccs args body)
) `thenC`
:: Id
-> CostCentreStack -- Optional cost centre annotation
-> StgBinderInfo
- -> SRT -- SRT info
-> [Id] -- Free vars
-> [Id] -- Args
-> StgExpr
-> [StgArg] -- payload
-> FCode (Id, CgIdInfo)
-cgStdRhsClosure binder cc binder_info srt fvs args body lf_info payload
+cgStdRhsClosure binder cc binder_info fvs args body lf_info payload
-- AHA! A STANDARD-FORM THUNK
= (
-- LAY OUT THE OBJECT
-- RETURN
returnFC (binder, heapIdInfo binder heap_offset lf_info)
-
- where
- is_std_thunk = isStandardFormThunk lf_info
\end{code}
Here's the general case.
cgRhsClosure :: Id
-> CostCentreStack -- Optional cost centre annotation
-> StgBinderInfo
- -> SRT -- SRT info
-> [Id] -- Free vars
-> [Id] -- Args
-> StgExpr
-> LambdaFormInfo
-> FCode (Id, CgIdInfo)
-cgRhsClosure binder cc binder_info srt fvs args body lf_info
+cgRhsClosure binder cc binder_info fvs args body lf_info
= (
-- LAY OUT THE OBJECT
--
nopC) `thenC`
-- Compile the body
- closureCodeBody binder_info srt closure_info cc args body
+ closureCodeBody binder_info closure_info cc args body
) `thenC`
-- BUILD THE OBJECT
\begin{code}
closureCodeBody :: StgBinderInfo
- -> SRT
-> ClosureInfo -- Lots of information about this closure
-> CostCentreStack -- Optional cost centre attached to closure
-> [Id]
are the same.
\begin{code}
-closureCodeBody binder_info srt closure_info cc [] body
+closureCodeBody binder_info closure_info cc [] body
= -- thunks cannot have a primitive type!
getAbsC body_code `thenFC` \ body_absC ->
moduleName `thenFC` \ mod_name ->
- getSRTLabel `thenFC` \ srt_label ->
absC (CClosureInfoAndCode closure_info body_absC Nothing
- (srt_label, srt) (cl_descr mod_name))
+ (cl_descr mod_name))
where
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`
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
- enterCostCentreCode closure_info cc IsThunk `thenC`
+ enterCostCentreCode closure_info cc IsThunk is_box `thenC`
cgExpr body)
\end{code}
Node points to closure is available. -- HWL
\begin{code}
-closureCodeBody binder_info srt closure_info cc all_args body
+closureCodeBody binder_info closure_info cc all_args body
= getEntryConvention name lf_info
(map idPrimRep all_args) `thenFC` \ entry_conv ->
-- 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
-- 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
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))
-- fast_entry_code = forceHeapCheck [] True fast_entry_code'
fast_entry_code
- = profCtrC SLIT("TICK_ENT_FUN_DIRECT") [
- 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.
freeStackSlots (map fst stk_tags) `thenC`
-- Enter the closures cc, if required
- enterCostCentreCode closure_info cc IsFunction `thenC`
+ 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 ->
- getSRTLabel `thenFC` \ srt_label ->
+ 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)
- (srt_label, srt) (cl_descr mod_name)
- else
+ absC (
+ if info_table_needed then
+ CClosureInfoAndCode closure_info slow_abs_c (Just fast_abs_c)
+ (cl_descr mod_name)
+ else
CCodeBlock fast_label fast_abs_c
+ )
)
where
+ ticky_ctr_label = mkRednCountsLabel name
+
stg_arity = length all_args
lf_info = closureLFInfo closure_info
-- 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
\begin{code}
data IsThunk = IsThunk | IsFunction -- Bool-like, local
---#ifdef DEBUG
+-- #ifdef DEBUG
deriving Eq
---#endif
+-- #endif
-enterCostCentreCode :: ClosureInfo -> CostCentreStack -> IsThunk -> Code
+enterCostCentreCode
+ :: ClosureInfo -> CostCentreStack
+ -> IsThunk
+ -> Bool -- is_box: this closure is a special box introduced by SCCfinal
+ -> Code
-enterCostCentreCode closure_info ccs is_thunk
+enterCostCentreCode closure_info ccs is_thunk is_box
= if not opt_SccProfilingOn then
nopC
else
ASSERT(not (noCCSAttached ccs))
if isSubsumedCCS ccs then
- --ASSERT(isToplevClosure closure_info)
- --ASSERT(is_thunk == IsFunction)
- (if isToplevClosure closure_info && is_thunk == IsFunction then \x->x
- else pprTrace "enterCostCenterCode:" (hsep [ppr (is_thunk == IsFunction),
- ppr ccs])) $
+ ASSERT(isToplevClosure closure_info)
+ ASSERT(is_thunk == IsFunction)
costCentresC SLIT("ENTER_CCS_FSUB") []
-
+
else if isCurrentCCS ccs then
- -- get CCC out of the closure, where we put it when we alloc'd
- case is_thunk of
- IsThunk -> costCentresC SLIT("ENTER_CCS_TCL") [CReg node]
- IsFunction -> costCentresC SLIT("ENTER_CCS_FCL") [CReg node]
+ if re_entrant && not is_box
+ then costCentresC SLIT("ENTER_CCS_FCL") [CReg node]
+ else costCentresC SLIT("ENTER_CCS_TCL") [CReg node]
- else if isCafCCS ccs && isToplevClosure closure_info then
+ else if isCafCCS ccs then
+ ASSERT(isToplevClosure closure_info)
ASSERT(is_thunk == IsThunk)
- costCentresC SLIT("ENTER_CCS_CAF") c_ccs
-
- else -- we've got a "real" cost centre right here in our hands...
- case is_thunk of
- IsThunk -> costCentresC SLIT("ENTER_CCS_T") c_ccs
- IsFunction -> if isCafCCS ccs-- || isDictCC ccs
- then costCentresC SLIT("ENTER_CCS_FCAF") c_ccs
- else costCentresC SLIT("ENTER_CCS_FLOAD") c_ccs
+ -- 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
+
+ else panic "enterCostCentreCode"
+
where
c_ccs = [mkCCostCentreStack ccs]
+ re_entrant = closureReEntrant closure_info
\end{code}
%************************************************************************
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)
\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
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
\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
+ let
+ use_cc = CMacroExpr PtrRep CCS_HDR [nodeReg]
+ 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}
%************************************************************************
blame_cc -- cost-centre on whom we blame the allocation
= case (args, fvs, body) of
- ([], [just1], StgApp fun [{-no args-}])
- | just1 == fun
+ ([], _, StgApp fun [{-no args-}])
-> mkCCostCentreStack overheadCCS
_ -> use_cc
projects / ghc-hetmet.git / blobdiff