%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgClosure.lhs,v 1.48 2001/09/10 10:07:21 rje Exp $
+% $Id: CgClosure.lhs,v 1.56 2002/03/14 15:27:17 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, 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
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
+cgTopRhsClosure id ccs binder_info srt args body lf_info
=
-- LAY OUT THE OBJECT
+ getSRTInfo srt `thenFC` \ srt_info ->
let
name = idName id
- closure_info = layOutStaticNoFVClosure name lf_info
- closure_label = mkClosureLabel name
+ 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)
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
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
--
else fvs
in
mapFCs getCAddrModeAndInfo reduced_fvs `thenFC` \ fvs_w_amodes_and_info ->
+ getSRTInfo srt `thenFC` \ srt_info ->
let
closure_info :: ClosureInfo
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
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 SLIT("TICK_ENT_STATIC_THK")
+ else SLIT("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
DirectEntry lbl arity regs -> regs
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
--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`
mkCString (_PK_ (map (showTypeCategory . idType) all_args))
]
let prof =
- profCtrC SLIT("TICK_ENT_FUN_DIRECT") [
+ profCtrC fast_ticky_ent_lit [
CLbl ticky_ctr_label DataPtrRep
]
where
ticky_ctr_label = mkRednCountsLabel name
+ (slow_ticky_ent_lit, fast_ticky_ent_lit) =
+ if (isStaticClosure closure_info)
+ then (SLIT("TICK_ENT_STATIC_FUN_STD"), SLIT("TICK_ENT_STATIC_FUN_DIRECT"))
+ else (SLIT("TICK_ENT_DYN_FUN_STD"), SLIT("TICK_ENT_DYN_FUN_DIRECT"))
+
stg_arity = length all_args
lf_info = closureLFInfo closure_info
-- 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}
= 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") []
- 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]
-> 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 (
in
(use_cc, blame_cc)
\end{code}
-
-
-
projects / ghc-hetmet.git / blobdiff