Commit 74b1006e authored by simonm's avatar simonm

[project @ 1999-03-11 11:32:22 by simonm]

Save a few bytes by ommitting the static link field on closures with
an empty SRT.
parent 6a074eb7
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
% $Id: AbsCSyn.lhs,v 1.20 1999/03/03 17:41:13 simonm Exp $
% $Id: AbsCSyn.lhs,v 1.21 1999/03/11 11:32:22 simonm Exp $
%
\section[AbstractC]{Abstract C: the last stop before machine code}
......@@ -185,7 +185,6 @@ stored in a mixed type location.)
AbstractC -- Slow entry point code
(Maybe AbstractC)
-- Fast entry point code, if any
(CLabel,SRT) -- SRT info
String -- Closure description; NB we can't get this
-- from ClosureInfo, because the latter refers
-- to the *right* hand side of a defn, whereas
......
......@@ -305,11 +305,11 @@ flatAbsC (AbsCStmts s1 s2)
returnFlt (mkAbsCStmts inline_s1 inline_s2,
mkAbsCStmts top_s1 top_s2)
flatAbsC (CClosureInfoAndCode cl_info slow maybe_fast srt descr)
flatAbsC (CClosureInfoAndCode cl_info slow maybe_fast descr)
= flatAbsC slow `thenFlt` \ (slow_heres, slow_tops) ->
flat_maybe maybe_fast `thenFlt` \ (fast_heres, fast_tops) ->
returnFlt (AbsCNop, mkAbstractCs [slow_tops, fast_tops,
CClosureInfoAndCode cl_info slow_heres fast_heres srt descr]
CClosureInfoAndCode cl_info slow_heres fast_heres descr]
)
flatAbsC (CCodeBlock label abs_C)
......
......@@ -217,7 +217,7 @@ costs absC =
CStaticClosure _ _ _ _ -> nullCosts
CClosureInfoAndCode _ _ _ _ _ -> nullCosts
CClosureInfoAndCode _ _ _ _ -> nullCosts
CRetDirect _ _ _ _ -> nullCosts
......
......@@ -359,7 +359,7 @@ pprAbsC stmt@(CStaticClosure closure_lbl cl_info cost_centre amodes) _
ppLocalnessMacro True{-include dyn-} info_lbl,
char ')'
],
nest 2 (ppr_payload (amodes ++ padding_wds)),
nest 2 (ppr_payload (amodes ++ padding_wds ++ static_link_field)),
ptext SLIT("};") ]
}
where
......@@ -378,16 +378,18 @@ pprAbsC stmt@(CStaticClosure closure_lbl cl_info cost_centre amodes) _
where
rep = getAmodeRep item
-- always at least one padding word: this is the static link field for
-- the garbage collector.
padding_wds =
if not (closureUpdReqd cl_info) then
[mkIntCLit 0]
[]
else
case 1 + (max 0 (mIN_UPD_SIZE - length amodes)) of { still_needed ->
case max 0 (mIN_UPD_SIZE - length amodes) of { still_needed ->
nOfThem still_needed (mkIntCLit 0) } -- a bunch of 0s
pprAbsC stmt@(CClosureInfoAndCode cl_info slow maybe_fast srt cl_descr) _
static_link_field
| staticClosureNeedsLink cl_info = [mkIntCLit 0]
| otherwise = []
pprAbsC stmt@(CClosureInfoAndCode cl_info slow maybe_fast cl_descr) _
= vcat [
hcat [
ptext SLIT("INFO_TABLE"),
......@@ -435,7 +437,8 @@ pprAbsC stmt@(CClosureInfoAndCode cl_info slow maybe_fast srt cl_descr) _
is_constr = maybeToBool maybe_tag
(Just tag) = maybe_tag
needs_srt = has_srt srt && needsSRT cl_info
needs_srt = infoTblNeedsSRT cl_info
srt = getSRTInfo cl_info
size = closureNonHdrSize cl_info
......@@ -1461,7 +1464,7 @@ ppr_decls_AbsC (CStaticClosure closure_lbl closure_info cost_centre amodes)
-- ToDo: strictly speaking, should chk "cost_centre" amode
= ppr_decls_Amodes amodes
ppr_decls_AbsC (CClosureInfoAndCode cl_info slow maybe_fast _ _)
ppr_decls_AbsC (CClosureInfoAndCode cl_info slow maybe_fast _)
= ppr_decls_Amodes [entry_lbl] `thenTE` \ p1 ->
ppr_decls_AbsC slow `thenTE` \ p2 ->
(case maybe_fast of
......
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
% $Id: CgClosure.lhs,v 1.24 1999/03/02 14:34:36 sof Exp $
% $Id: CgClosure.lhs,v 1.25 1999/03/11 11:32:25 simonm Exp $
%
\section[CgClosure]{Code generation for closures}
......@@ -72,13 +72,12 @@ They should have no free variables.
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
......@@ -107,7 +106,7 @@ cgTopRhsClosure id ccs binder_info srt args body 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`
......@@ -132,7 +131,6 @@ cgStdRhsClosure
:: Id
-> CostCentreStack -- Optional cost centre annotation
-> StgBinderInfo
-> SRT -- SRT info
-> [Id] -- Free vars
-> [Id] -- Args
-> StgExpr
......@@ -140,7 +138,7 @@ cgStdRhsClosure
-> [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
......@@ -169,14 +167,13 @@ 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
--
......@@ -223,7 +220,7 @@ cgRhsClosure binder cc binder_info srt fvs args body lf_info
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
......@@ -245,7 +242,6 @@ cgRhsClosure binder cc binder_info srt fvs args body lf_info
\begin{code}
closureCodeBody :: StgBinderInfo
-> SRT
-> ClosureInfo -- Lots of information about this closure
-> CostCentreStack -- Optional cost centre attached to closure
-> [Id]
......@@ -260,14 +256,13 @@ no argument satisfaction check, so fast and slow entry-point labels
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)
......@@ -291,7 +286,7 @@ argSatisfactionCheck (by calling fetchAndReschedule). There info if
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 ->
......@@ -408,7 +403,6 @@ closureCodeBody binder_info srt closure_info cc all_args body
`thenFC` \ slow_abs_c ->
forkAbsC fast_entry_code `thenFC` \ fast_abs_c ->
moduleName `thenFC` \ mod_name ->
getSRTLabel `thenFC` \ srt_label ->
-- Now either construct the info table, or put the fast code in alone
-- (We never have slow code without an info table)
......@@ -417,7 +411,7 @@ closureCodeBody binder_info srt closure_info cc all_args body
absC (
if info_table_needed then
CClosureInfoAndCode closure_info slow_abs_c (Just fast_abs_c)
(srt_label, srt) (cl_descr mod_name)
(cl_descr mod_name)
else
CCodeBlock fast_label fast_abs_c
)
......
......@@ -138,13 +138,9 @@ genConInfo comp_info tycon data_con
closure_code = if zero_arity_con then
AbsCNop
else
CClosureInfoAndCode closure_info body Nothing
srt_info con_descr
CClosureInfoAndCode closure_info body Nothing con_descr
srt_info = (error "genConInfo: no srt label", NoSRT)
static_code = CClosureInfoAndCode static_ci body Nothing
srt_info con_descr
static_code = CClosureInfoAndCode static_ci body Nothing con_descr
tag = dataConTag data_con
......
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
% $Id: CgExpr.lhs,v 1.19 1999/01/14 17:58:46 sof Exp $
% $Id: CgExpr.lhs,v 1.20 1999/03/11 11:32:26 simonm Exp $
%
%********************************************************
%* *
......@@ -303,7 +303,7 @@ mkRhsClosure bndr cc bi srt
&& maybeToBool maybe_offset -- Selectee is a component of the tuple
&& offset_into_int <= mAX_SPEC_SELECTEE_SIZE -- Offset is small enough
= ASSERT(is_single_constructor)
cgStdRhsClosure bndr cc bi srt [the_fv] [] body lf_info [StgVarArg the_fv]
cgStdRhsClosure bndr cc bi [the_fv] [] body lf_info [StgVarArg the_fv]
where
lf_info = mkSelectorLFInfo (idType bndr) offset_into_int
(isUpdatable upd_flag)
......@@ -345,7 +345,7 @@ mkRhsClosure bndr cc bi srt
&& arity <= mAX_SPEC_AP_SIZE
-- Ha! an Ap thunk
= cgStdRhsClosure bndr cc bi srt fvs [] body lf_info payload
= cgStdRhsClosure bndr cc bi fvs [] body lf_info payload
where
lf_info = mkApLFInfo (idType bndr) upd_flag arity
......@@ -359,8 +359,11 @@ The default case
~~~~~~~~~~~~~~~~
\begin{code}
mkRhsClosure bndr cc bi srt fvs upd_flag args body
= cgRhsClosure bndr cc bi srt fvs args body lf_info
where lf_info = mkClosureLFInfo bndr NotTopLevel fvs upd_flag args
= getSRTLabel `thenFC` \ srt_label ->
let lf_info =
mkClosureLFInfo bndr NotTopLevel fvs upd_flag args srt_label srt
in
cgRhsClosure bndr cc bi fvs args body lf_info
\end{code}
......
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
% $Id: ClosureInfo.lhs,v 1.34 1999/03/04 17:52:08 simonm Exp $
% $Id: ClosureInfo.lhs,v 1.35 1999/03/11 11:32:27 simonm Exp $
%
\section[ClosureInfo]{Data structures which describe closures}
......@@ -50,7 +50,10 @@ module ClosureInfo (
allocProfilingMsg,
blackHoleClosureInfo,
maybeSelectorInfo,
needsSRT
infoTblNeedsSRT,
staticClosureNeedsLink,
getSRTInfo
) where
#include "HsVersions.h"
......@@ -118,6 +121,8 @@ data LambdaFormInfo
TopLevelFlag -- True if top level
!Int -- Arity
!Bool -- True <=> no fvs
CLabel -- SRT label
SRT -- SRT info
| LFCon -- Constructor
DataCon -- The constructor
......@@ -133,6 +138,8 @@ data LambdaFormInfo
!Bool -- True <=> no free vars
Bool -- True <=> updatable (i.e., *not* single-entry)
StandardFormInfo
CLabel -- SRT label
SRT -- SRT info
| LFArgument -- Used for function arguments. We know nothing about
-- this closure. Treat like updatable "LFThunk"...
......@@ -199,20 +206,23 @@ mkClosureLFInfo :: Id -- The binder
-> [Id] -- Free vars
-> UpdateFlag -- Update flag
-> [Id] -- Args
-> CLabel -- SRT label
-> SRT -- SRT info
-> LambdaFormInfo
mkClosureLFInfo bndr top fvs upd_flag args@(_:_) -- Non-empty args
= LFReEntrant (idType bndr) top (length args) (null fvs)
mkClosureLFInfo bndr top fvs upd_flag args@(_:_) srt_label srt -- Non-empty args
= LFReEntrant (idType bndr) top (length args) (null fvs) srt_label srt
mkClosureLFInfo bndr top fvs ReEntrant []
= LFReEntrant (idType bndr) top 0 (null fvs)
mkClosureLFInfo bndr top fvs ReEntrant [] srt_label srt
= LFReEntrant (idType bndr) top 0 (null fvs) srt_label srt
mkClosureLFInfo bndr top fvs upd_flag []
mkClosureLFInfo bndr top fvs upd_flag [] srt_label srt
#ifdef DEBUG
| isUnLiftedType ty = pprPanic "mkClosureLFInfo" (ppr bndr <+> ppr ty)
#endif
| otherwise
= LFThunk ty top (null fvs) (isUpdatable upd_flag) NonStandardThunk
srt_label srt
where
ty = idType bndr
\end{code}
......@@ -228,10 +238,14 @@ mkConLFInfo con
mkSelectorLFInfo rhs_ty offset updatable
= LFThunk rhs_ty NotTopLevel False updatable (SelectorThunk offset)
(error "mkSelectorLFInfo: no srt label")
(error "mkSelectorLFInfo: no srt")
mkApLFInfo rhs_ty upd_flag arity
= LFThunk rhs_ty NotTopLevel (arity == 0) (isUpdatable upd_flag)
(ApThunk arity)
(error "mkApLFInfo: no srt label")
(error "mkApLFInfo: no srt")
\end{code}
Miscellaneous LF-infos.
......@@ -247,7 +261,11 @@ mkLFImported id
ArityExactly 0 -> LFThunk (idType id)
TopLevel True{-no fvs-}
True{-updatable-} NonStandardThunk
(error "mkLFImported: no srt label")
(error "mkLFImported: no srt")
ArityExactly n -> LFReEntrant (idType id) TopLevel n True -- n > 0
(error "mkLFImported: no srt label")
(error "mkLFImported: no srt")
other -> LFImported -- Not sure of exact arity
\end{code}
......@@ -434,14 +452,14 @@ chooseDynSMRep lf_info tot_wds ptr_wds
getStaticClosureType :: LambdaFormInfo -> ClosureType
getStaticClosureType lf_info =
case lf_info of
LFCon con True -> CONSTR_NOCAF
LFCon con False -> CONSTR
LFReEntrant _ _ _ _ -> FUN
LFTuple _ _ -> CONSTR
LFThunk _ _ _ _ (SelectorThunk _) -> THUNK_SELECTOR
LFThunk _ _ _ True _ -> THUNK
LFThunk _ _ _ False _ -> FUN
_ -> panic "getClosureType"
LFCon con True -> CONSTR_NOCAF
LFCon con False -> CONSTR
LFReEntrant _ _ _ _ _ _ -> FUN
LFTuple _ _ -> CONSTR
LFThunk _ _ _ _ (SelectorThunk _) _ _ -> THUNK_SELECTOR
LFThunk _ _ _ True _ _ _ -> THUNK
LFThunk _ _ _ False _ _ _ -> FUN
_ -> panic "getClosureType"
-- we *do* get non-updatable top-level thunks sometimes. eg. f = g
-- gets compiled to a jump to g (if g has non-zero arity), instead of
......@@ -457,7 +475,7 @@ getClosureType tot_wds ptrs nptrs lf_info =
| tot_wds > 0 && tot_wds <= mAX_SPEC_CONSTR_SIZE -> CONSTR_p_n ptrs nptrs
| otherwise -> CONSTR
LFReEntrant _ _ _ _
LFReEntrant _ _ _ _ _ _
| tot_wds > 0 && tot_wds <= mAX_SPEC_FUN_SIZE -> FUN_p_n ptrs nptrs
| otherwise -> FUN
......@@ -465,9 +483,9 @@ getClosureType tot_wds ptrs nptrs lf_info =
| tot_wds > 0 && tot_wds <= mAX_SPEC_CONSTR_SIZE -> CONSTR_p_n ptrs nptrs
| otherwise -> CONSTR
LFThunk _ _ _ _ (SelectorThunk _) -> THUNK_SELECTOR
LFThunk _ _ _ _ (SelectorThunk _) _ _ -> THUNK_SELECTOR
LFThunk _ _ _ _ _
LFThunk _ _ _ _ _ _ _
| tot_wds > 0 && tot_wds <= mAX_SPEC_THUNK_SIZE -> THUNK_p_n ptrs nptrs
| otherwise -> THUNK
......@@ -523,7 +541,7 @@ nodeMustPointToIt :: LambdaFormInfo -> FCode Bool
nodeMustPointToIt lf_info
= case lf_info of
LFReEntrant ty top arity no_fvs -> returnFC (
LFReEntrant ty top arity no_fvs _ _ -> returnFC (
not no_fvs || -- Certainly if it has fvs we need to point to it
case top of { TopLevel -> False; _ -> True }
-- If it is not top level we will point to it
......@@ -550,7 +568,7 @@ nodeMustPointToIt lf_info
-- having Node point to the result of an update. SLPJ
-- 27/11/92.
LFThunk _ _ no_fvs updatable NonStandardThunk
LFThunk _ _ no_fvs updatable NonStandardThunk _ _
-> returnFC (updatable || not no_fvs || opt_SccProfilingOn)
-- For the non-updatable (single-entry case):
......@@ -560,7 +578,7 @@ nodeMustPointToIt lf_info
-- or profiling (in which case we need to recover the cost centre
-- from inside it)
LFThunk _ _ no_fvs updatable some_standard_form_thunk
LFThunk _ _ no_fvs updatable some_standard_form_thunk _ _
-> returnFC True
-- Node must point to any standard-form thunk.
......@@ -633,7 +651,7 @@ getEntryConvention name lf_info arg_kinds
case lf_info of
LFReEntrant _ _ arity _ ->
LFReEntrant _ _ arity _ _ _ ->
if arity == 0 || (length arg_kinds) < arity then
StdEntry (mkStdEntryLabel name)
else
......@@ -659,7 +677,7 @@ getEntryConvention name lf_info arg_kinds
-- Should have no args (meaning what?)
StdEntry (mkConEntryLabel (dataConName tup))
LFThunk _ _ _ updatable std_form_info
LFThunk _ _ _ updatable std_form_info _ _
-> if updatable
then ViaNode
else StdEntry (thunkEntryLabel name std_form_info updatable)
......@@ -694,9 +712,9 @@ blackHoleOnEntry (MkClosureInfo _ _ (StaticRep _ _ _)) = False
blackHoleOnEntry (MkClosureInfo _ lf_info _)
= case lf_info of
LFReEntrant _ _ _ _ -> False
LFReEntrant _ _ _ _ _ _ -> False
LFLetNoEscape _ -> False
LFThunk _ _ no_fvs updatable _
LFThunk _ _ no_fvs updatable _ _ _
-> if updatable
then not opt_OmitBlackHoling
else not no_fvs
......@@ -704,23 +722,45 @@ blackHoleOnEntry (MkClosureInfo _ lf_info _)
isStandardFormThunk :: LambdaFormInfo -> Bool
isStandardFormThunk (LFThunk _ _ _ _ (SelectorThunk _)) = True
isStandardFormThunk (LFThunk _ _ _ _ (ApThunk _)) = True
isStandardFormThunk other_lf_info = False
isStandardFormThunk (LFThunk _ _ _ _ (SelectorThunk _) _ _) = True
isStandardFormThunk (LFThunk _ _ _ _ (ApThunk _) _ _) = True
isStandardFormThunk other_lf_info = False
maybeSelectorInfo (MkClosureInfo _ (LFThunk _ _ _ _
(SelectorThunk offset)) _) = Just offset
(SelectorThunk offset) _ _) _) = Just offset
maybeSelectorInfo _ = Nothing
\end{code}
-----------------------------------------------------------------------------
SRT-related stuff
-- Does this thunk's info table have an SRT?
needsSRT :: ClosureInfo -> Bool
needsSRT (MkClosureInfo _ info _) =
\begin{code}
infoTblNeedsSRT :: ClosureInfo -> Bool
infoTblNeedsSRT (MkClosureInfo _ info _) =
case info of
LFThunk _ _ _ _ (SelectorThunk _) -> False -- not for selectors
LFThunk _ _ _ _ _ -> True
LFReEntrant _ _ _ _ -> True
LFThunk _ _ _ _ _ _ NoSRT -> False
LFThunk _ _ _ _ _ _ _ -> True
LFReEntrant _ _ _ _ _ NoSRT -> False
LFReEntrant _ _ _ _ _ _ -> True
_ -> False
staticClosureNeedsLink :: ClosureInfo -> Bool
staticClosureNeedsLink (MkClosureInfo _ info _) =
case info of
LFThunk _ _ _ _ _ _ NoSRT -> False
LFReEntrant _ _ _ _ _ NoSRT -> False
LFCon _ True -> False -- zero arity constructors
_ -> True
getSRTInfo :: ClosureInfo -> (CLabel, SRT)
getSRTInfo (MkClosureInfo _ info _) =
case info of
LFThunk _ _ _ _ _ lbl srt -> (lbl,srt)
LFReEntrant _ _ _ _ lbl srt -> (lbl,srt)
_ -> panic "getSRTInfo"
\end{code}
Avoiding generating entries and info tables
......@@ -791,7 +831,7 @@ staticClosureRequired
-> LambdaFormInfo
-> Bool
staticClosureRequired binder (StgBinderInfo arg_occ unsat_occ _ _ _)
(LFReEntrant _ top_level _ _) -- It's a function
(LFReEntrant _ top_level _ _ _ _) -- It's a function
= ASSERT( case top_level of { TopLevel -> True; other -> False } )
-- Assumption: it's a top-level, no-free-var binding
arg_occ -- There's an argument occurrence
......@@ -821,7 +861,7 @@ funInfoTableRequired
-> LambdaFormInfo
-> Bool
funInfoTableRequired binder (StgBinderInfo arg_occ unsat_occ _ _ _)
(LFReEntrant _ top_level _ _)
(LFReEntrant _ top_level _ _ _ _)
= (case top_level of { NotTopLevel -> True; TopLevel -> False })
|| arg_occ -- There's an argument occurrence
|| unsat_occ -- There's an unsaturated call
......@@ -852,7 +892,7 @@ closureLFInfo (MkClosureInfo _ lf_info _) = lf_info
closureUpdReqd :: ClosureInfo -> Bool
closureUpdReqd (MkClosureInfo _ (LFThunk _ _ _ upd _) _) = upd
closureUpdReqd (MkClosureInfo _ (LFThunk _ _ _ upd _ _ _) _) = upd
closureUpdReqd (MkClosureInfo _ LFBlackHole _) = True
-- Black-hole closures are allocated to receive the results of an
-- alg case with a named default... so they need to be updated.
......@@ -860,7 +900,7 @@ closureUpdReqd other_closure = False
closureSingleEntry :: ClosureInfo -> Bool
closureSingleEntry (MkClosureInfo _ (LFThunk _ _ _ upd _) _) = not upd
closureSingleEntry (MkClosureInfo _ (LFThunk _ _ _ upd _ _ _) _) = not upd
closureSingleEntry other_closure = False
\end{code}
......@@ -879,8 +919,8 @@ isToplevClosure :: ClosureInfo -> Bool
isToplevClosure (MkClosureInfo _ lf_info _)
= case lf_info of
LFReEntrant _ TopLevel _ _ -> True
LFThunk _ TopLevel _ _ _ -> True
LFReEntrant _ TopLevel _ _ _ _ -> True
LFThunk _ TopLevel _ _ _ _ _ -> True
other -> False
\end{code}
......@@ -895,7 +935,7 @@ Label generation.
\begin{code}
fastLabelFromCI :: ClosureInfo -> CLabel
fastLabelFromCI (MkClosureInfo name (LFReEntrant _ _ arity _) _)
fastLabelFromCI (MkClosureInfo name (LFReEntrant _ _ arity _ _ _) _)
= mkFastEntryLabel name arity
fastLabelFromCI (MkClosureInfo name _ _)
......@@ -909,10 +949,10 @@ infoTableLabelFromCI (MkClosureInfo id lf_info rep)
LFBlackHole -> mkBlackHoleInfoTableLabel
LFThunk _ _ _ upd_flag (SelectorThunk offset) ->
LFThunk _ _ _ upd_flag (SelectorThunk offset) _ _ ->
mkSelectorInfoLabel upd_flag offset
LFThunk _ _ _ upd_flag (ApThunk arity) ->
LFThunk _ _ _ upd_flag (ApThunk arity) _ _ ->
mkApInfoTableLabel upd_flag arity
other -> {-NO: if isStaticRep rep
......@@ -945,7 +985,7 @@ closureLabelFromCI (MkClosureInfo id _ other_rep) = mkClosureLabel id
entryLabelFromCI :: ClosureInfo -> CLabel
entryLabelFromCI (MkClosureInfo id lf_info rep)
= case lf_info of
LFThunk _ _ _ upd_flag std_form_info -> thunkEntryLabel id std_form_info upd_flag
LFThunk _ _ _ upd_flag std_form_info _ _ -> thunkEntryLabel id std_form_info upd_flag
LFCon con _ -> mkConEntryPtr con rep
LFTuple tup _ -> mkConEntryPtr tup rep
other -> mkStdEntryLabel id
......@@ -966,10 +1006,10 @@ allocProfilingMsg :: ClosureInfo -> FAST_STRING
allocProfilingMsg (MkClosureInfo _ lf_info _)
= case lf_info of
LFReEntrant _ _ _ _ -> SLIT("TICK_ALLOC_FUN")
LFReEntrant _ _ _ _ _ _ -> SLIT("TICK_ALLOC_FUN")
LFCon _ _ -> SLIT("TICK_ALLOC_CON")
LFTuple _ _ -> SLIT("TICK_ALLOC_CON")
LFThunk _ _ _ _ _ -> SLIT("TICK_ALLOC_THK")
LFThunk _ _ _ _ _ _ _ -> SLIT("TICK_ALLOC_THK")
LFBlackHole -> SLIT("TICK_ALLOC_BH")
LFImported -> panic "TICK_ALLOC_IMP"
\end{code}
......@@ -999,9 +1039,9 @@ in the closure info using @closureTypeDescr@.
\begin{code}
closureTypeDescr :: ClosureInfo -> String
closureTypeDescr (MkClosureInfo name (LFThunk ty _ _ _ _) _)
closureTypeDescr (MkClosureInfo name (LFThunk ty _ _ _ _ _ _) _)
= getTyDescription ty
closureTypeDescr (MkClosureInfo name (LFReEntrant ty _ _ _) _)
closureTypeDescr (MkClosureInfo name (LFReEntrant ty _ _ _ _ _) _)
= getTyDescription ty
closureTypeDescr (MkClosureInfo name lf _)
= showSDoc (ppr name)
......
......@@ -183,7 +183,9 @@ cgTopRhs bndr (StgRhsCon cc con args)
cgTopRhs bndr (StgRhsClosure cc bi srt fvs upd_flag args body)
= ASSERT(null fvs) -- There should be no free variables
forkStatics (cgTopRhsClosure bndr cc bi srt args body lf_info)
where
lf_info = mkClosureLFInfo bndr TopLevel [{-no fvs-}] upd_flag args
getSRTLabel `thenFC` \srt_label ->
let lf_info =
mkClosureLFInfo bndr TopLevel [{-no fvs-}] upd_flag args srt_label srt
in
forkStatics (cgTopRhsClosure bndr cc bi args body lf_info)
\end{code}
......@@ -23,7 +23,8 @@ import SMRep ( fixedItblSize,
import Constants ( mIN_UPD_SIZE )
import CLabel ( CLabel, mkReturnInfoLabel, mkReturnPtLabel )
import ClosureInfo ( infoTableLabelFromCI, entryLabelFromCI,
fastLabelFromCI, closureUpdReqd
fastLabelFromCI, closureUpdReqd,
staticClosureNeedsLink
)
import Const ( Literal(..) )
import Maybes ( maybeToBool )
......@@ -97,7 +98,7 @@ Here we handle top-level things, like @CCodeBlock@s and
LvSmall _ -> rET_SMALL
LvLarge _ -> rET_BIG
gentopcode stmt@(CClosureInfoAndCode cl_info slow Nothing _ _)
gentopcode stmt@(CClosureInfoAndCode cl_info slow Nothing _)
| slow_is_empty
= genCodeInfoTable stmt `thenUs` \ itbl ->
......@@ -112,7 +113,7 @@ Here we handle top-level things, like @CCodeBlock@s and
slow_is_empty = not (maybeToBool (nonemptyAbsC slow))
slow_lbl = entryLabelFromCI cl_info
gentopcode stmt@(CClosureInfoAndCode cl_info slow (Just fast) _ _) =
gentopcode stmt@(CClosureInfoAndCode cl_info slow (Just fast) _) =
-- ToDo: what if this is empty? ------------------------^^^^
genCodeInfoTable stmt `thenUs` \ itbl ->
gencode slow `thenUs` \ slow_code ->
......@@ -171,14 +172,17 @@ Here we handle top-level things, like @CCodeBlock@s and
where
table = StData PtrRep [StCLbl (infoTableLabelFromCI cl_info)] :