%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: AbsCSyn.lhs,v 1.37 2001/07/24 05:04:58 ken Exp $
+% $Id: AbsCSyn.lhs,v 1.38 2001/09/26 15:11:50 simonpj Exp $
%
\section[AbstractC]{Abstract C: the last stop before machine code}
module AbsCSyn {- (
-- export everything
AbstractC(..),
+ C_SRT(..)
CStmtMacro(..),
CExprMacro(..),
CAddrMode(..),
import ForeignCall ( CCallSpec )
import PrimRep ( PrimRep(..) )
import Unique ( Unique )
-import StgSyn ( StgOp, SRT(..) )
+import StgSyn ( StgOp )
import TyCon ( TyCon )
import BitSet -- for liveness masks
import FastTypes
| CRetDirect -- Direct return
!Unique -- for making labels
AbstractC -- return code
- (CLabel,SRT) -- SRT info
+ C_SRT -- SRT info
Liveness -- stack liveness at the return point
-- see the notes about these next few; they follow below...
| CRetVector -- A labelled block of static data
CLabel
[CAddrMode]
- (CLabel,SRT) -- SRT info
+ C_SRT -- SRT info
Liveness -- stack liveness at the return point
| CClosureTbl -- table of constructors for enumerated types
-- CostCentre.lhs)
| CSplitMarker -- Split into separate object modules here
+
+-- C_SRT is what StgSyn.SRT gets translated to...
+-- we add a label for the table, and expect only the 'offset/length' form
+
+data C_SRT = NoC_SRT
+ | C_SRT CLabel !Int{-offset-} !Int{-length-}
+
+needsSRT :: C_SRT -> Bool
+needsSRT NoC_SRT = False
+needsSRT (C_SRT _ _ _) = True
\end{code}
About @CMacroStmt@, etc.: notionally, they all just call some
import UniqSet ( emptyUniqSet, elementOfUniqSet,
addOneToUniqSet, UniqSet
)
-import StgSyn ( SRT(..), StgOp(..) )
+import StgSyn ( StgOp(..) )
import BitSet ( BitSet, intBS )
import Outputable
import GlaExts
is_constr = maybeToBool maybe_tag
(Just tag) = maybe_tag
- needs_srt = infoTblNeedsSRT cl_info
- srt = getSRTInfo cl_info
+ srt = closureSRT cl_info
+ needs_srt = case srt of
+ NoC_SRT -> False
+ other -> True
+
size = closureNonHdrSize cl_info
\end{code}
\begin{code}
-pp_srt_info srt =
- case srt of
- (lbl, NoSRT) ->
- hcat [ int 0, comma,
- int 0, comma,
- int 0, comma ]
- (lbl, SRT off len) ->
- hcat [ pprCLabel lbl, comma,
- int off, comma,
- int len, comma ]
+pp_srt_info NoC_SRT = hcat [ int 0, comma,
+ int 0, comma,
+ int 0, comma ]
+pp_srt_info (C_SRT lbl off len) = hcat [ pprCLabel lbl, comma,
+ int off, comma,
+ int len, comma ]
\end{code}
\begin{code}
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgCase.lhs,v 1.52 2001/05/22 13:43:15 simonpj Exp $
+% $Id: CgCase.lhs,v 1.53 2001/09/26 15:11:50 simonpj Exp $
%
%********************************************************
%* *
[alt] -> let lbl = mkReturnInfoLabel uniq in
cgUnboxedTupleAlt uniq cc_slot True alt
`thenFC` \ abs_c ->
- getSRTLabel `thenFC` \srt_label ->
- absC (CRetDirect uniq abs_c (srt_label, srt)
+ getSRTInfo srt `thenFC` \ srt_info ->
+ absC (CRetDirect uniq abs_c srt_info
liveness_mask) `thenC`
returnFC (CaseAlts (CLbl lbl RetRep) Nothing)
_ -> panic "cgEvalAlts: dodgy case of unboxed tuple type"
getAbsC (cgPrimEvalAlts bndr tycon alts deflt) `thenFC` \ abs_c ->
-- Generate the labelled block, starting with restore-cost-centre
- getSRTLabel `thenFC` \srt_label ->
+ getSRTInfo srt `thenFC` \srt_info ->
absC (CRetDirect uniq (cc_restore `mkAbsCStmts` abs_c)
- (srt_label,srt) liveness_mask) `thenC`
+ srt_info liveness_mask) `thenC`
-- Return an amode for the block
returnFC (CaseAlts (CLbl (mkReturnInfoLabel uniq) RetRep) Nothing)
-> FCode CAddrMode
mkReturnVector uniq tagged_alt_absCs deflt_absC srt liveness ret_conv
- = getSRTLabel `thenFC` \srt_label ->
+ = getSRTInfo srt `thenFC` \ srt_info ->
let
(return_vec_amode, vtbl_body) = case ret_conv of {
UnvectoredReturn 0 ->
ASSERT(null tagged_alt_absCs)
(CLbl ret_label RetRep,
- absC (CRetDirect uniq deflt_absC (srt_label, srt) liveness));
+ absC (CRetDirect uniq deflt_absC srt_info liveness));
UnvectoredReturn n ->
-- find the tag explicitly rather than using tag_reg for now.
(CLbl ret_label RetRep,
absC (CRetDirect uniq
(mkAlgAltsCSwitch tag tagged_alt_absCs deflt_absC)
- (srt_label, srt)
+ srt_info
liveness));
VectoredReturn table_size ->
(vector_table, alts_absC) =
unzip (map mk_vector_entry [fIRST_TAG .. (table_size+fIRST_TAG-1)])
- ret_vector = CRetVector vtbl_label
- vector_table
- (srt_label, srt) liveness
+ ret_vector = CRetVector vtbl_label vector_table srt_info liveness
in
(CLbl vtbl_label DataPtrRep,
-- alts come first, because we don't want to declare all the symbols
%
% (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.49 2001/09/26 15:11:50 simonpj Exp $
%
\section[CgClosure]{Code generation for closures}
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_info = layOutStaticNoFVClosure name lf_info srt_info
closure_label = mkClosureLabel name
cg_id_info = stableAmodeIdInfo id (CLbl closure_label PtrRep) lf_info
in
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
import CgTailCall ( performReturn, mkStaticAlgReturnCode, doTailCall,
mkUnboxedTupleReturnCode )
import CLabel ( mkClosureLabel )
-import ClosureInfo ( mkConLFInfo, mkLFArgument,
- layOutDynCon, layOutDynClosure,
- layOutStaticClosure, closureSize
+import ClosureInfo ( mkConLFInfo, mkLFArgument, closureLFInfo,
+ layOutDynConstr, layOutDynClosure,
+ layOutStaticConstr, closureSize
)
import CostCentre ( currentOrSubsumedCCS, dontCareCCS, CostCentreStack,
currentCCS )
cgTopRhsCon id con args
= ASSERT(not (isDllConApp con args)) -- checks for litlit args too
ASSERT(length args == dataConRepArity con)
- let
- name = idName id
- closure_label = mkClosureLabel name
- lf_info = mkConLFInfo con
- in
- (
-- LAY IT OUT
getArgAmodes args `thenFC` \ amodes ->
let
- (closure_info, amodes_w_offsets)
- = layOutStaticClosure name getAmodeRep amodes lf_info
+ name = idName id
+ closure_label = mkClosureLabel name
+ lf_info = closureLFInfo closure_info
+ (closure_info, amodes_w_offsets) = layOutStaticConstr name con getAmodeRep amodes
in
-- BUILD THE OBJECT
(mkCCostCentreStack dontCareCCS) -- because it's static data
(map fst amodes_w_offsets)) -- Sorted into ptrs first, then nonptrs
- ) `thenC`
+ `thenC`
-- RETURN
returnFC (id, stableAmodeIdInfo id (CLbl closure_label PtrRep) lf_info)
returnFC (heapIdInfo binder hp_off lf_info)
where
(closure_info, amodes_w_offsets)
- = layOutDynClosure (idName binder) getAmodeRep args lf_info
+ = layOutDynClosure (idName binder) getAmodeRep args lf_info NoC_SRT
lf_info = mkConLFInfo con
use_cc -- cost-centre to stick in the object
mapCs bind_arg args_w_offsets
where
bind_arg (arg, offset) = bindNewToNode arg offset mkLFArgument
- (_, args_w_offsets) = layOutDynCon con idPrimRep args
+ (_, args_w_offsets) = layOutDynConstr bogus_name con idPrimRep args
+
+bogus_name = panic "bindConArgs"
\end{code}
Unboxed tuples are handled slightly differently - the object is
bindUnboxedTupleComponents args
= -- Assign as many components as possible to registers
- let (arg_regs, leftovers) = assignRegs [] (map idPrimRep args)
- (reg_args, stk_args) = splitAt (length arg_regs) args
+ let (arg_regs, _leftovers) = assignRegs [] (map idPrimRep args)
+ (reg_args, stk_args) = splitAt (length arg_regs) args
in
-- Allocate the rest on the stack (ToDo: separate out pointers)
setEndOfBlockInfo (EndOfBlockInfo new_sp (OnStack new_sp)) $
performReturn (AbsCNop) (mkStaticAlgReturnCode con)
- where (closure_info, stuff)
- = layOutDynClosure (dataConName con)
- getAmodeRep amodes lf_info
-
- lf_info = mkConLFInfo con
+ where
+ (closure_info, stuff)
+ = layOutDynConstr (dataConName con) con getAmodeRep amodes
other_sequel -- The usual case
import AbsCUtils ( mkAbstractCs, mkAbsCStmts )
import CgTailCall ( performReturn, mkStaticAlgReturnCode )
-import ClosureInfo ( layOutStaticClosure, layOutDynCon,
- mkConLFInfo, ClosureInfo
- )
+import ClosureInfo ( layOutStaticConstr, layOutDynConstr, ClosureInfo )
import DataCon ( DataCon, dataConName, dataConRepArgTys, isNullaryDataCon )
import Name ( getOccName )
import OccName ( occNameUserString )
-- To allow the debuggers, interpreters, etc to cope with static
-- data structures (ie those built at compile time), we take care that
-- info-table contains the information we need.
- (static_ci,_) = layOutStaticClosure con_name typePrimRep arg_tys
- (mkConLFInfo data_con)
+ (static_ci,_) = layOutStaticConstr con_name data_con typePrimRep arg_tys
body = (initC comp_info (
profCtrC SLIT("TICK_ENT_CON") [CReg node] `thenC`
arg_tys = dataConRepArgTys con
(closure_info, arg_things)
- = layOutDynCon con typePrimRep arg_tys
+ = layOutDynConstr (dataConName con) con typePrimRep arg_tys
body_code
= -- NB: We don't set CC when entering data (WDP 94/06)
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgExpr.lhs,v 1.43 2001/05/22 13:43:15 simonpj Exp $
+% $Id: CgExpr.lhs,v 1.44 2001/09/26 15:11:50 simonpj Exp $
%
%********************************************************
%* *
tailCallPrimOp, returnUnboxedTuple
)
import ClosureInfo ( mkClosureLFInfo, mkSelectorLFInfo,
- mkApLFInfo, layOutDynCon )
+ mkApLFInfo, layOutDynConstr )
import CostCentre ( sccAbleCostCentre, isSccCountCostCentre )
import Id ( idPrimRep, idType, Id )
import VarSet
cgStdRhsClosure bndr cc bi [the_fv] [] body lf_info [StgVarArg the_fv]
where
lf_info = mkSelectorLFInfo (idType bndr) offset_into_int
- (isUpdatable upd_flag)
- (_, params_w_offsets) = layOutDynCon con idPrimRep params
+ (isUpdatable upd_flag)
+ (_, params_w_offsets) = layOutDynConstr bogus_name con idPrimRep params -- Just want the layout
maybe_offset = assocMaybe params_w_offsets selectee
Just the_offset = maybe_offset
offset_into_int = the_offset - fixedHdrSize
is_single_constructor = maybeToBool (maybeTyConSingleCon tycon)
+ bogus_name = panic "mkRhsClosure"
\end{code}
-
-
Ap thunks
~~~~~~~~~
~~~~~~~~~~~~~~~~
\begin{code}
mkRhsClosure bndr cc bi srt fvs upd_flag args body
- = 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
+ = cgRhsClosure bndr cc bi srt fvs args body lf_info
+ where
+ lf_info = mkClosureLFInfo bndr NotTopLevel fvs upd_flag args
\end{code}
%
% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
%
-% $Id: CgLetNoEscape.lhs,v 1.14 2000/07/11 16:03:37 simonmar Exp $
+% $Id: CgLetNoEscape.lhs,v 1.15 2001/09/26 15:11:50 simonpj Exp $
%
%********************************************************
%* *
(allocStackTop retPrimRepSize `thenFC` \_ ->
nukeDeadBindings full_live_in_rhss)
- (deAllocStackTop retPrimRepSize `thenFC` \_ ->
- buildContLivenessMask uniq `thenFC` \ liveness ->
+ (deAllocStackTop retPrimRepSize `thenFC` \_ ->
+ buildContLivenessMask uniq `thenFC` \ liveness ->
forkAbsC (cgLetNoEscapeBody binder cc args body uniq)
`thenFC` \ code ->
- getSRTLabel `thenFC` \ srt_label ->
- absC (CRetDirect uniq code (srt_label,srt) liveness)
+ getSRTInfo srt `thenFC` \ srt_info ->
+ absC (CRetDirect uniq code srt_info liveness)
`thenC` returnFC ())
`thenFC` \ (vSp, _) ->
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgMonad.lhs,v 1.29 2001/08/31 12:39:06 rje Exp $
+% $Id: CgMonad.lhs,v 1.30 2001/09/26 15:11:50 simonpj Exp $
%
\section[CgMonad]{The code generation monad}
EndOfBlockInfo(..),
setEndOfBlockInfo, getEndOfBlockInfo,
- setSRTLabel, getSRTLabel,
+ setSRTLabel, getSRTLabel, getSRTInfo,
setTickyCtrLabel, getTickyCtrLabel,
StackUsage, Slot(..), HeapUsage,
import {-# SOURCE #-} CgUsages ( getSpRelOffset )
import AbsCSyn
+import StgSyn ( SRT(..) )
import AbsCUtils ( mkAbsCStmts )
import CmdLineOpts ( opt_SccProfilingOn, opt_DoTickyProfiling )
import CLabel ( CLabel, mkUpdInfoLabel, mkTopTickyCtrLabel )
\end{code}
\begin{code}
-getSRTLabel :: FCode CLabel
-getSRTLabel = do
- (MkCgInfoDown _ _ srt _ _) <- getInfoDown
- return srt
+getSRTInfo :: SRT -> FCode C_SRT
+getSRTInfo NoSRT = return NoC_SRT
+getSRTInfo (SRT off len) = do srt_lbl <- getSRTLabel
+ return (C_SRT srt_lbl off len)
+
+getSRTLabel :: FCode CLabel -- Used only by cgPanic
+getSRTLabel = do MkCgInfoDown _ _ srt_lbl _ _ <- getInfoDown
+ return srt_lbl
setSRTLabel :: CLabel -> Code -> Code
-setSRTLabel srt code = do
- (MkCgInfoDown c_info statics _ ticky eob_info) <- getInfoDown
- withInfoDown code (MkCgInfoDown c_info statics srt ticky eob_info)
+setSRTLabel srt_lbl code
+ = do MkCgInfoDown c_info statics _ ticky eob_info <- getInfoDown
+ withInfoDown code (MkCgInfoDown c_info statics srt_lbl ticky eob_info)
\end{code}
\begin{code}
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: ClosureInfo.lhs,v 1.47 2001/05/22 13:43:15 simonpj Exp $
+% $Id: ClosureInfo.lhs,v 1.48 2001/09/26 15:11:50 simonpj Exp $
%
\section[ClosureInfo]{Data structures which describe closures}
closureGoodStuffSize, closurePtrsSize,
slopSize,
- layOutDynClosure, layOutDynCon, layOutStaticClosure,
- layOutStaticNoFVClosure,
+ layOutDynClosure, layOutDynConstr, layOutStaticClosure,
+ layOutStaticNoFVClosure, layOutStaticConstr,
mkVirtHeapOffsets,
nodeMustPointToIt, getEntryConvention,
slowFunEntryCodeRequired, funInfoTableRequired,
closureName, infoTableLabelFromCI, fastLabelFromCI,
- closureLabelFromCI,
+ closureLabelFromCI, closureSRT,
entryLabelFromCI,
closureLFInfo, closureSMRep, closureUpdReqd,
closureSingleEntry, closureReEntrant, closureSemiTag,
cafBlackHoleClosureInfo, seCafBlackHoleClosureInfo,
maybeSelectorInfo,
- infoTblNeedsSRT,
staticClosureNeedsLink,
- getSRTInfo
) where
#include "HsVersions.h"
-import AbsCSyn ( MagicId, node, VirtualHeapOffset, HeapOffset )
+import AbsCSyn ( MagicId, node, VirtualHeapOffset, HeapOffset, C_SRT(..), needsSRT )
import StgSyn
import CgMonad
import Outputable
\end{code}
-The ``wrapper'' data type for closure information:
-
-\begin{code}
-data ClosureInfo
- = MkClosureInfo
- Name -- The thing bound to this closure
- LambdaFormInfo -- info derivable from the *source*
- SMRep -- representation used by storage manager
-\end{code}
-
%************************************************************************
%* *
\subsection[ClosureInfo-datatypes]{Data types for closure information}
%* *
%************************************************************************
+The ``wrapper'' data type for closure information:
+
+\begin{code}
+data ClosureInfo
+ = MkClosureInfo {
+ closureName :: Name, -- The thing bound to this closure
+ closureLFInfo :: LambdaFormInfo, -- Info derivable from the *source*
+ closureSMRep :: SMRep, -- representation used by storage manager
+ closureSRT :: C_SRT -- What SRT applies to this closure
+ }
+\end{code}
+
%************************************************************************
%* *
\subsubsection[LambdaFormInfo-datatype]{@LambdaFormInfo@: source-derivable info}
TopLevelFlag -- True if top level
!Int -- Arity
!Bool -- True <=> no fvs
- CLabel -- SRT label
- SRT -- SRT info
| LFCon -- Constructor
DataCon -- The constructor
!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"...
-> [Id] -- Free vars
-> UpdateFlag -- Update flag
-> [Id] -- Args
- -> CLabel -- SRT label
- -> SRT -- SRT info
-> LambdaFormInfo
-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 upd_flag args@(_:_) -- Non-empty args
+ = LFReEntrant (idType bndr) top (length args) (null fvs)
-mkClosureLFInfo bndr top fvs ReEntrant [] srt_label srt
- = LFReEntrant (idType bndr) top 0 (null fvs) srt_label srt
+mkClosureLFInfo bndr top fvs ReEntrant []
+ = LFReEntrant (idType bndr) top 0 (null fvs)
-mkClosureLFInfo bndr top fvs upd_flag [] srt_label srt
+mkClosureLFInfo bndr top fvs upd_flag []
#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}
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")
+ = LFThunk rhs_ty NotTopLevel (arity == 0)
+ (isUpdatable upd_flag) (ApThunk arity)
\end{code}
Miscellaneous LF-infos.
mkLFImported id
= case idCgArity id of
n | n > 0 -> 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}
\begin{code}
closureSize :: ClosureInfo -> HeapOffset
-closureSize cl_info@(MkClosureInfo _ _ sm_rep)
- = fixedHdrSize + closureNonHdrSize cl_info
+closureSize cl_info = fixedHdrSize + closureNonHdrSize cl_info
closureNonHdrSize :: ClosureInfo -> Int
-closureNonHdrSize cl_info@(MkClosureInfo _ lf_info sm_rep)
- = tot_wds + computeSlopSize tot_wds sm_rep (closureUpdReqd cl_info)
- --ToDo: pass lf_info?
+closureNonHdrSize cl_info
+ = tot_wds + computeSlopSize tot_wds
+ (closureSMRep cl_info)
+ (closureUpdReqd cl_info)
where
tot_wds = closureGoodStuffSize cl_info
+slopSize :: ClosureInfo -> Int
+slopSize cl_info
+ = computeSlopSize (closureGoodStuffSize cl_info)
+ (closureSMRep cl_info)
+ (closureUpdReqd cl_info)
+
closureGoodStuffSize :: ClosureInfo -> Int
-closureGoodStuffSize (MkClosureInfo _ _ sm_rep)
- = let (ptrs, nonptrs) = sizes_from_SMRep sm_rep
+closureGoodStuffSize cl_info
+ = let (ptrs, nonptrs) = sizes_from_SMRep (closureSMRep cl_info)
in ptrs + nonptrs
closurePtrsSize :: ClosureInfo -> Int
-closurePtrsSize (MkClosureInfo _ _ sm_rep)
- = let (ptrs, _) = sizes_from_SMRep sm_rep
+closurePtrsSize cl_info
+ = let (ptrs, _) = sizes_from_SMRep (closureSMRep cl_info)
in ptrs
-- not exported:
don't bother taking that into account here.
\begin{code}
-slopSize cl_info@(MkClosureInfo _ lf_info sm_rep)
- = computeSlopSize (closureGoodStuffSize cl_info) sm_rep
- (closureUpdReqd cl_info)
-
computeSlopSize :: Int -> SMRep -> Bool -> Int
computeSlopSize tot_wds (GenericRep _ _ _ _) True -- Updatable
-> (a -> PrimRep) -- how to get a PrimRep for the fields
-> [a] -- the "things" being layed out
-> LambdaFormInfo -- what sort of closure it is
+ -> C_SRT
-> (ClosureInfo, -- info about the closure
[(a, VirtualHeapOffset)]) -- things w/ offsets pinned on them
-layOutDynClosure name kind_fn things lf_info
- = (MkClosureInfo name lf_info sm_rep,
+layOutDynClosure name kind_fn things lf_info srt_info
+ = (MkClosureInfo { closureName = name, closureLFInfo = lf_info,
+ closureSMRep = sm_rep, closureSRT = srt_info },
things_w_offsets)
where
(tot_wds, -- #ptr_wds + #nonptr_wds
sm_rep = chooseDynSMRep lf_info tot_wds ptr_wds
\end{code}
-A wrapper for when used with data constructors:
+Wrappers for when used with data constructors:
\begin{code}
-layOutDynCon :: DataCon
- -> (a -> PrimRep)
- -> [a]
- -> (ClosureInfo, [(a,VirtualHeapOffset)])
+layOutDynConstr, layOutStaticConstr
+ :: Name -- Of the closure
+ -> DataCon
+ -> (a -> PrimRep) -> [a]
+ -> (ClosureInfo, [(a,VirtualHeapOffset)])
+
+layOutDynConstr name data_con kind_fn args
+ = layOutDynClosure name kind_fn args (mkConLFInfo data_con) NoC_SRT
-layOutDynCon con kind_fn args
- = layOutDynClosure (dataConName con) kind_fn args (mkConLFInfo con)
+layOutStaticConstr name data_con kind_fn things
+ = layOutStaticClosure name kind_fn things (mkConLFInfo data_con) NoC_SRT
\end{code}
%************************************************************************
layOutStaticNoFVClosure.
\begin{code}
-layOutStaticClosure name kind_fn things lf_info
- = (MkClosureInfo name lf_info
- (GenericRep is_static ptr_wds (tot_wds - ptr_wds) closure_type),
+layOutStaticClosure name kind_fn things lf_info srt_info
+ = (MkClosureInfo { closureName = name, closureLFInfo = lf_info,
+ closureSMRep = rep, closureSRT = srt_info },
things_w_offsets)
where
+ rep = GenericRep is_static ptr_wds (tot_wds - ptr_wds) closure_type
+
(tot_wds, -- #ptr_wds + #nonptr_wds
ptr_wds, -- #ptr_wds
things_w_offsets) = mkVirtHeapOffsets kind_fn things
closure_type = getClosureType is_static tot_wds ptr_wds lf_info
is_static = True
-layOutStaticNoFVClosure :: Name -> LambdaFormInfo -> ClosureInfo
-layOutStaticNoFVClosure name lf_info
- = MkClosureInfo name lf_info (GenericRep is_static 0 0 (getClosureType is_static 0 0 lf_info))
+layOutStaticNoFVClosure :: Name -> LambdaFormInfo -> C_SRT -> ClosureInfo
+layOutStaticNoFVClosure name lf_info srt_info
+ = MkClosureInfo { closureName = name, closureLFInfo = lf_info,
+ closureSMRep = rep, closureSRT = srt_info }
where
+ rep = GenericRep is_static 0 0 (getClosureType is_static 0 0 lf_info)
is_static = True
\end{code}
| specialised_rep mAX_SPEC_CONSTR_SIZE -> CONSTR_p_n
| otherwise -> CONSTR
- LFReEntrant _ _ _ _ _ _
+ LFReEntrant _ _ _ _
| specialised_rep mAX_SPEC_FUN_SIZE -> FUN_p_n
| otherwise -> FUN
- LFThunk _ _ _ _ (SelectorThunk _) _ _ -> THUNK_SELECTOR
+ LFThunk _ _ _ _ (SelectorThunk _) -> THUNK_SELECTOR
- LFThunk _ _ _ _ _ _ _
+ LFThunk _ _ _ _ _
| specialised_rep mAX_SPEC_THUNK_SIZE -> THUNK_p_n
| otherwise -> THUNK
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
isNotTopLevel top
-- If it is not top level we will point to it
-- 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):
-- 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.
case lf_info of
- LFReEntrant _ _ arity _ _ _ ->
+ LFReEntrant _ _ arity _ ->
if arity == 0 || (length arg_kinds) < arity then
StdEntry (mkStdEntryLabel name)
else
-- Should have no args (meaning what?)
StdEntry (mkConEntryLabel (dataConName tup))
- LFThunk _ _ _ updatable std_form_info _ _
+ LFThunk _ _ _ updatable std_form_info
-> if updatable || opt_DoTickyProfiling -- to catch double entry
|| opt_SMP -- always enter via node on SMP, since the
-- thunk might have been blackholed in the
-- Single-entry ones have no fvs to plug, and we trust they don't form part
-- of a loop.
-blackHoleOnEntry (MkClosureInfo _ _ rep)
- | isStaticRep rep
- = False
- -- Never black-hole a static closure
+blackHoleOnEntry cl_info
+ | isStaticRep (closureSMRep cl_info)
+ = False -- Never black-hole a static closure
-blackHoleOnEntry (MkClosureInfo _ lf_info _)
- = case lf_info of
- LFReEntrant _ _ _ _ _ _ -> False
+ | otherwise
+ = case closureLFInfo cl_info of
+ LFReEntrant _ _ _ _ -> False
LFLetNoEscape _ -> False
- LFThunk _ _ no_fvs updatable _ _ _
+ LFThunk _ _ no_fvs updatable _
-> if updatable
then not opt_OmitBlackHoling
else opt_DoTickyProfiling || not no_fvs
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
+maybeSelectorInfo (MkClosureInfo { closureLFInfo = LFThunk _ _ _ _ (SelectorThunk offset) })
+ = Just offset
maybeSelectorInfo _ = Nothing
\end{code}
-----------------------------------------------------------------------------
SRT-related stuff
-
\begin{code}
-infoTblNeedsSRT :: ClosureInfo -> Bool
-infoTblNeedsSRT (MkClosureInfo _ info _) =
- case info of
- 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"
+-- A static closure needs a link field to aid the GC when traversing
+-- the static closure graph. But it only needs such a field if either
+-- a) it has an SRT
+-- b) it's a non-nullary constructor
+-- In case (b), the constructor's fields themselves play the role
+-- of the SRT.
+staticClosureNeedsLink (MkClosureInfo { closureName = name, closureSRT = srt, closureLFInfo = info })
+ = needsSRT srt || constructor_srt
+ where
+ constructor_srt
+ = case info of
+ LFThunk _ _ _ _ _ -> False
+ LFReEntrant _ _ _ _ -> False
+ LFCon _ is_nullary -> not is_nullary
+ LFTuple _ is_nullary -> not is_nullary
+ other -> pprPanic "staticClosureNeedsLink" (ppr name)
\end{code}
Avoiding generating entries and info tables
-> LambdaFormInfo
-> Bool
staticClosureRequired binder bndr_info
- (LFReEntrant _ top_level _ _ _ _) -- It's a function
+ (LFReEntrant _ top_level _ _) -- It's a function
= ASSERT( isTopLevel top_level )
-- Assumption: it's a top-level, no-free-var binding
not (satCallsOnly bndr_info)
-> StgBinderInfo
-> LambdaFormInfo
-> Bool
-funInfoTableRequired binder bndr_info (LFReEntrant _ top_level _ _ _ _)
+funInfoTableRequired binder bndr_info (LFReEntrant _ top_level _ _)
= isNotTopLevel top_level
|| not (satCallsOnly bndr_info)
\begin{code}
isStaticClosure :: ClosureInfo -> Bool
-isStaticClosure (MkClosureInfo _ _ rep) = isStaticRep rep
-
-closureName :: ClosureInfo -> Name
-closureName (MkClosureInfo name _ _) = name
-
-closureSMRep :: ClosureInfo -> SMRep
-closureSMRep (MkClosureInfo _ _ sm_rep) = sm_rep
-
-closureLFInfo :: ClosureInfo -> LambdaFormInfo
-closureLFInfo (MkClosureInfo _ lf_info _) = lf_info
+isStaticClosure cl_info = isStaticRep (closureSMRep cl_info)
closureUpdReqd :: ClosureInfo -> Bool
-closureUpdReqd (MkClosureInfo _ (LFThunk _ _ _ upd _ _ _) _) = upd
-closureUpdReqd (MkClosureInfo _ (LFBlackHole _) _) = True
+closureUpdReqd (MkClosureInfo { closureLFInfo = LFThunk _ _ _ upd _ }) = upd
+closureUpdReqd (MkClosureInfo { closureLFInfo = 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.
-closureUpdReqd other_closure = False
+closureUpdReqd other_closure = False
closureSingleEntry :: ClosureInfo -> Bool
-closureSingleEntry (MkClosureInfo _ (LFThunk _ _ _ upd _ _ _) _) = not upd
-closureSingleEntry other_closure = False
+closureSingleEntry (MkClosureInfo { closureLFInfo = LFThunk _ _ _ upd _ }) = not upd
+closureSingleEntry other_closure = False
closureReEntrant :: ClosureInfo -> Bool
-closureReEntrant (MkClosureInfo _ (LFReEntrant _ _ _ _ _ _) _) = True
+closureReEntrant (MkClosureInfo { closureLFInfo = LFReEntrant _ _ _ _ }) = True
closureReEntrant other_closure = False
\end{code}
\begin{code}
closureSemiTag :: ClosureInfo -> Maybe Int
-closureSemiTag (MkClosureInfo _ lf_info _)
+closureSemiTag (MkClosureInfo { closureLFInfo = lf_info })
= case lf_info of
LFCon data_con _ -> Just (dataConTag data_con - fIRST_TAG)
LFTuple _ _ -> Just 0
\begin{code}
isToplevClosure :: ClosureInfo -> Bool
-isToplevClosure (MkClosureInfo _ lf_info _)
+isToplevClosure (MkClosureInfo { closureLFInfo = lf_info })
= case lf_info of
- LFReEntrant _ TopLevel _ _ _ _ -> True
- LFThunk _ TopLevel _ _ _ _ _ -> True
+ LFReEntrant _ TopLevel _ _ -> True
+ LFThunk _ TopLevel _ _ _ -> True
other -> False
\end{code}
\begin{code}
fastLabelFromCI :: ClosureInfo -> CLabel
-fastLabelFromCI (MkClosureInfo name (LFReEntrant _ _ arity _ _ _) _)
+fastLabelFromCI (MkClosureInfo { closureName = name, closureLFInfo = LFReEntrant _ _ arity _ })
= mkFastEntryLabel name arity
-fastLabelFromCI (MkClosureInfo name _ _)
- = pprPanic "fastLabelFromCI" (ppr name)
+fastLabelFromCI cl_info
+ = pprPanic "fastLabelFromCI" (ppr (closureName cl_info))
infoTableLabelFromCI :: ClosureInfo -> CLabel
-infoTableLabelFromCI (MkClosureInfo id lf_info rep)
+infoTableLabelFromCI (MkClosureInfo { closureName = id, closureLFInfo = lf_info, closureSMRep = rep })
= case lf_info of
LFCon con _ -> mkConInfoPtr con rep
LFTuple tup _ -> mkConInfoPtr tup rep
LFBlackHole info -> info
- 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
| isStaticRep rep = mkStaticConEntryLabel (dataConName con)
| otherwise = mkConEntryLabel (dataConName con)
-closureLabelFromCI (MkClosureInfo id _ other_rep) = mkClosureLabel id
+closureLabelFromCI cl_info = mkClosureLabel (closureName cl_info)
entryLabelFromCI :: ClosureInfo -> CLabel
-entryLabelFromCI (MkClosureInfo id lf_info rep)
+entryLabelFromCI (MkClosureInfo { closureName = id, closureLFInfo = lf_info, closureSMRep = 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
\begin{code}
allocProfilingMsg :: ClosureInfo -> FAST_STRING
-allocProfilingMsg (MkClosureInfo _ lf_info _)
- = case lf_info of
- LFReEntrant _ _ _ _ _ _ -> SLIT("TICK_ALLOC_FUN")
- LFCon _ _ -> SLIT("TICK_ALLOC_CON")
- LFTuple _ _ -> SLIT("TICK_ALLOC_CON")
- LFThunk _ _ _ True _ _ _ -> SLIT("TICK_ALLOC_UP_THK") -- updatable
- LFThunk _ _ _ False _ _ _ -> SLIT("TICK_ALLOC_SE_THK") -- nonupdatable
- LFBlackHole _ -> SLIT("TICK_ALLOC_BH")
- LFImported -> panic "TICK_ALLOC_IMP"
+allocProfilingMsg cl_info
+ = case closureLFInfo cl_info of
+ LFReEntrant _ _ _ _ -> SLIT("TICK_ALLOC_FUN")
+ LFCon _ _ -> SLIT("TICK_ALLOC_CON")
+ LFTuple _ _ -> SLIT("TICK_ALLOC_CON")
+ LFThunk _ _ _ True _ -> SLIT("TICK_ALLOC_UP_THK") -- updatable
+ LFThunk _ _ _ False _ -> SLIT("TICK_ALLOC_SE_THK") -- nonupdatable
+ LFBlackHole _ -> SLIT("TICK_ALLOC_BH")
+ LFImported -> panic "TICK_ALLOC_IMP"
\end{code}
We need a black-hole closure info to pass to @allocDynClosure@ when we
is a black hole and not something else.
\begin{code}
-cafBlackHoleClosureInfo (MkClosureInfo name _ _)
- = MkClosureInfo name (LFBlackHole mkCAFBlackHoleInfoTableLabel) BlackHoleRep
-
-seCafBlackHoleClosureInfo (MkClosureInfo name _ _)
- = MkClosureInfo name (LFBlackHole mkSECAFBlackHoleInfoTableLabel) BlackHoleRep
+cafBlackHoleClosureInfo cl_info
+ = MkClosureInfo { closureName = closureName cl_info,
+ closureLFInfo = LFBlackHole mkCAFBlackHoleInfoTableLabel,
+ closureSMRep = BlackHoleRep,
+ closureSRT = NoC_SRT }
+
+seCafBlackHoleClosureInfo cl_info
+ = MkClosureInfo { closureName = closureName cl_info,
+ closureLFInfo = LFBlackHole mkSECAFBlackHoleInfoTableLabel,
+ closureSMRep = BlackHoleRep,
+ closureSRT = NoC_SRT }
\end{code}
%************************************************************************
\begin{code}
closureTypeDescr :: ClosureInfo -> String
-closureTypeDescr (MkClosureInfo name (LFThunk ty _ _ _ _ _ _) _)
- = getTyDescription ty
-closureTypeDescr (MkClosureInfo name (LFReEntrant ty _ _ _ _ _) _)
- = getTyDescription ty
-closureTypeDescr (MkClosureInfo name (LFCon data_con _) _)
- = occNameUserString (getOccName (dataConTyCon data_con))
-closureTypeDescr (MkClosureInfo name lf _)
- = showSDoc (ppr name)
+closureTypeDescr cl_info
+ = case closureLFInfo cl_info of
+ LFThunk ty _ _ _ _ -> getTyDescription ty
+ LFReEntrant ty _ _ _ -> getTyDescription ty
+ LFCon data_con _ -> occNameUserString (getOccName (dataConTyCon data_con))
+ other -> showSDoc (ppr (closureName cl_info))
\end{code}
-
import Panic ( assertPanic )
#ifdef DEBUG
-import Id ( idCafInfo )
-import IdInfo ( mayHaveCafRefs )
import Outputable
#endif
\end{code}
cgTopRhs bndr (StgRhsClosure cc bi fvs upd_flag args body) srt
= -- There should be no free variables
ASSERT(null fvs)
-
- getSRTLabel `thenFC` \srt_label ->
- let lf_info =
- mkClosureLFInfo bndr TopLevel [{-no fvs-}] upd_flag args srt_label srt
+ let
+ lf_info = mkClosureLFInfo bndr TopLevel [{-no fvs-}] upd_flag args
in
- maybeGlobaliseId bndr `thenFC` \ bndr' ->
- forkStatics (cgTopRhsClosure bndr' cc bi args body lf_info)
+ maybeGlobaliseId bndr `thenFC` \ bndr' ->
+ forkStatics (cgTopRhsClosure bndr' cc bi srt args body lf_info)
\end{code}
snocOL, consOL, concatOL )
import AbsCUtils ( magicIdPrimRep )
import ForeignCall ( CCallConv(..) )
-import CLabel ( isAsmTemp, CLabel, labelDynamic )
-import Maybes ( maybeToBool, expectJust )
+import CLabel ( CLabel, labelDynamic )
+import Maybes ( maybeToBool )
import PrimRep ( isFloatingRep, PrimRep(..) )
import PrimOp ( PrimOp(..) )
import Stix ( getNatLabelNCG, StixTree(..),
#include "../includes/config.h"
#include "NCG.h"
-import AbsCSyn ( AbstractC(..), Liveness(..) )
+import AbsCSyn ( AbstractC(..), Liveness(..), C_SRT(..), needsSRT )
import CLabel ( CLabel )
import StgSyn ( SRT(..) )
import ClosureInfo ( closurePtrsSize,
closureNonHdrSize, closureSMRep,
infoTableLabelFromCI,
- infoTblNeedsSRT, getSRTInfo, closureSemiTag
+ closureSRT, closureSemiTag
)
import PrimRep ( PrimRep(..) )
import SMRep ( getSMRepClosureTypeInt )
where
info_lbl = infoTableLabelFromCI cl_info
- needs_srt = infoTblNeedsSRT cl_info
table | needs_srt = srt_label : rest_of_table
| otherwise = rest_of_table
type_info = (fromInt closure_type) .|.
(fromInt srt_len `shiftL` 16)
#endif
- srt = getSRTInfo cl_info
+ srt = closureSRT cl_info
+ needs_srt = needsSRT srt
(srt_label,srt_len)
| is_constr
= (StInt 0, tag)
- | needs_srt
- = case srt of
- (lbl, SRT off len) ->
- (StIndex DataPtrRep (StCLbl lbl)
- (StInt (toInteger off)), len)
| otherwise
- = (StInt 0, 0)
+ = case srt of
+ NoC_SRT -> (StInt 0, 0)
+ C_SRT lbl off len -> (StIndex DataPtrRep (StCLbl lbl) (StInt (toInteger off)), len)
maybe_tag = closureSemiTag cl_info
is_constr = maybeToBool maybe_tag
genBitmapInfoTable
:: Liveness
- -> (CLabel, SRT)
+ -> C_SRT
-> Int
-> Bool -- must include SRT field (i.e. it's a vector)
-> UniqSM StixTreeList
(srt_label,srt_len) =
case srt of
- (lbl, NoSRT) -> (StInt 0, 0)
- (lbl, SRT off len) ->
+ NoC_SRT -> (StInt 0, 0)
+ C_SRT lbl off len ->
(StIndex DataPtrRep (StCLbl lbl)
(StInt (toInteger off)), len)
import FastTypes hiding ( fastOr )
import Outputable
-import List ( partition )
-
infixr 9 `thenLne`
\end{code}
the actual nested SRTs, and replaces the lists of Ids with (offset,length)
pairs.
+
+Interaction of let-no-escape with SRTs [Sept 01]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+
+ let-no-escape x = ...caf1...caf2...
+ in
+ ...x...x...x...
+
+where caf1,caf2 are CAFs. Since x doesn't have a closure, we
+build SRTs just as if x's defn was inlined at each call site, and
+that means that x's CAF refs get duplicated in the overall SRT.
+
+This is unlike ordinary lets, in which the CAF refs are not duplicated.
+
+We could fix this loss of (static) sharing by making a sort of pseudo-closure
+for x, solely to put in the SRTs lower down.
+
+
%************************************************************************
%* *
\subsection[binds-StgVarInfo]{Setting variable info: top-level, binds, RHSs}
coreTopBindToStg env body_fvs (NonRec id rhs)
= let
- caf_info = hasCafRefs env rhs
-
- env' = extendVarEnv env id (LetBound how_bound emptyLVS (predictArity rhs))
-
- how_bound | mayHaveCafRefs caf_info = TopLevelHasCafs
- | otherwise = TopLevelNoCafs
+ caf_info = hasCafRefs env rhs
+ env' = extendVarEnv env id how_bound
+ how_bound = LetBound (TopLet caf_info) (predictArity rhs)
- (stg_rhs, fvs', cafs) =
+ (stg_rhs, fvs', lv_info) =
initLne env (
- coreToStgRhs body_fvs TopLevel (id,rhs)
- `thenLne` \ (stg_rhs, fvs', _) ->
- freeVarsToLiveVars fvs' `thenLne` \ (_, cafs) ->
- returnLne (stg_rhs, fvs', cafs)
+ coreToStgRhs body_fvs TopLevel (id,rhs) `thenLne` \ (stg_rhs, fvs', _) ->
+ freeVarsToLiveVars fvs' `thenLne` \ lv_info ->
+ returnLne (stg_rhs, fvs', lv_info)
)
- bind = StgNonRec (SRTEntries cafs) id stg_rhs
+ bind = StgNonRec (mkSRT lv_info) id stg_rhs
in
ASSERT2(predictArity rhs == stgRhsArity stg_rhs, ppr id)
ASSERT2(consistent caf_info bind, ppr id)
= let
(binders, rhss) = unzip pairs
- -- to calculate caf_info, we initially map all the binders to
- -- TopLevelNoCafs.
+ -- To calculate caf_info, we initially map
+ -- all the binders to NoCafRefs
env1 = extendVarEnvList env
- [ (b, LetBound TopLevelNoCafs emptyLVS (error "no arity"))
+ [ (b, LetBound (TopLet NoCafRefs) (error "no arity"))
| b <- binders ]
caf_info = hasCafRefss env1{-NB: not env'-} rhss
env' = extendVarEnvList env
- [ (b, LetBound how_bound emptyLVS (predictArity rhs))
+ [ (b, LetBound (TopLet caf_info) (predictArity rhs))
| (b,rhs) <- pairs ]
- how_bound | mayHaveCafRefs caf_info = TopLevelHasCafs
- | otherwise = TopLevelNoCafs
-
- (stg_rhss, fvs', cafs)
+ (stg_rhss, fvs', lv_info)
= initLne env' (
mapAndUnzip3Lne (coreToStgRhs body_fvs TopLevel) pairs
`thenLne` \ (stg_rhss, fvss', _) ->
let fvs' = unionFVInfos fvss' in
- freeVarsToLiveVars fvs' `thenLne` \ (_, cafs) ->
- returnLne (stg_rhss, fvs', cafs)
+ freeVarsToLiveVars fvs' `thenLne` \ lv_info ->
+ returnLne (stg_rhss, fvs', lv_info)
)
- bind = StgRec (SRTEntries cafs) (zip binders stg_rhss)
+ bind = StgRec (mkSRT lv_info) (zip binders stg_rhss)
in
ASSERT2(and [predictArity rhs == stgRhsArity stg_rhs | (rhs,stg_rhs) <- rhss `zip` stg_rhss], ppr binders)
ASSERT2(consistent caf_info bind, ppr binders)
(f, args) = myCollectArgs expr
coreToStgExpr expr@(Lam _ _)
- = let (args, body) = myCollectBinders expr
+ = let
+ (args, body) = myCollectBinders expr
args' = filterStgBinders args
in
extendVarEnvLne [ (a, LambdaBound) | a <- args' ] $
coreToStgExpr body `thenLne` \ (body, body_fvs, body_escs) ->
let
- set_of_args = mkVarSet args'
fvs = args' `minusFVBinders` body_fvs
- escs = body_escs `minusVarSet` set_of_args
+ escs = body_escs `delVarSetList` args'
result_expr | null args' = body
| otherwise = StgLam (exprType expr) args' body
in
coreToStgExpr (Note other_note expr)
= coreToStgExpr expr
-
-- Cases require a little more real work.
coreToStgExpr (Case scrut bndr alts)
- = extendVarEnvLne [(bndr, CaseBound)] $
- vars_alts (findDefault alts) `thenLne` \ (alts2, alts_fvs, alts_escs) ->
- freeVarsToLiveVars alts_fvs `thenLne` \ (alts_lvs, alts_caf_refs) ->
+ = extendVarEnvLne [(bndr, LambdaBound)] (
+ mapAndUnzip3Lne vars_alt alts `thenLne` \ (alts2, fvs_s, escs_s) ->
+ returnLne ( mkStgAlts (idType bndr) alts2,
+ unionFVInfos fvs_s,
+ unionVarSets escs_s )
+ ) `thenLne` \ (alts2, alts_fvs, alts_escs) ->
let
- -- determine whether the default binder is dead or not
+ -- Determine whether the default binder is dead or not
-- This helps the code generator to avoid generating an assignment
-- for the case binder (is extremely rare cases) ToDo: remove.
- bndr'= if (bndr `elementOfFVInfo` alts_fvs)
- then bndr
- else bndr `setIdOccInfo` IAmDead
+ bndr' | bndr `elementOfFVInfo` alts_fvs = bndr
+ | otherwise = bndr `setIdOccInfo` IAmDead
-- Don't consider the default binder as being 'live in alts',
-- since this is from the point of view of the case expr, where
-- the default binder is not free.
- live_in_alts = (alts_lvs `minusVarSet` unitVarSet bndr)
+ alts_fvs_wo_bndr = bndr `minusFVBinder` alts_fvs
+ alts_escs_wo_bndr = alts_escs `delVarSet` bndr
in
- -- we tell the scrutinee that everything live in the alts
- -- is live in it, too.
- setVarsLiveInCont (live_in_alts,alts_caf_refs) (
+
+ freeVarsToLiveVars alts_fvs_wo_bndr `thenLne` \ alts_lv_info ->
+
+ -- We tell the scrutinee that everything
+ -- live in the alts is live in it, too.
+ setVarsLiveInCont alts_lv_info (
coreToStgExpr scrut `thenLne` \ (scrut2, scrut_fvs, scrut_escs) ->
- freeVarsToLiveVars scrut_fvs `thenLne` \ (scrut_lvs, _) ->
- returnLne (scrut2, scrut_fvs, scrut_escs, scrut_lvs)
+ freeVarsToLiveVars scrut_fvs `thenLne` \ scrut_lv_info ->
+ returnLne (scrut2, scrut_fvs, scrut_escs, scrut_lv_info)
)
- `thenLne` \ (scrut2, scrut_fvs, scrut_escs, scrut_lvs) ->
+ `thenLne` \ (scrut2, scrut_fvs, scrut_escs, scrut_lv_info) ->
- let srt = SRTEntries alts_caf_refs
- in
returnLne (
- StgCase scrut2 scrut_lvs live_in_alts bndr' srt alts2,
- bndr `minusFVBinder` (scrut_fvs `unionFVInfo` alts_fvs),
- (alts_escs `minusVarSet` unitVarSet bndr) `unionVarSet` getFVSet scrut_fvs
+ StgCase scrut2 (getLiveVars scrut_lv_info)
+ (getLiveVars alts_lv_info)
+ bndr'
+ (mkSRT alts_lv_info)
+ alts2,
+ scrut_fvs `unionFVInfo` alts_fvs_wo_bndr,
+ alts_escs_wo_bndr `unionVarSet` getFVSet scrut_fvs
-- You might think we should have scrut_escs, not
-- (getFVSet scrut_fvs), but actually we can't call, and
-- then return from, a let-no-escape thing.
)
where
- scrut_ty = idType bndr
- prim_case = isUnLiftedType scrut_ty && not (isUnboxedTupleType scrut_ty)
-
- vars_alts (alts,deflt)
- | prim_case
- = mapAndUnzip3Lne vars_prim_alt alts
- `thenLne` \ (alts2, alts_fvs_list, alts_escs_list) ->
- let
- alts_fvs = unionFVInfos alts_fvs_list
- alts_escs = unionVarSets alts_escs_list
- in
- vars_deflt deflt `thenLne` \ (deflt2, deflt_fvs, deflt_escs) ->
- returnLne (
- mkStgPrimAlts scrut_ty alts2 deflt2,
- alts_fvs `unionFVInfo` deflt_fvs,
- alts_escs `unionVarSet` deflt_escs
- )
-
- | otherwise
- = mapAndUnzip3Lne vars_alg_alt alts
- `thenLne` \ (alts2, alts_fvs_list, alts_escs_list) ->
- let
- alts_fvs = unionFVInfos alts_fvs_list
- alts_escs = unionVarSets alts_escs_list
- in
- vars_deflt deflt `thenLne` \ (deflt2, deflt_fvs, deflt_escs) ->
- returnLne (
- mkStgAlgAlts scrut_ty alts2 deflt2,
- alts_fvs `unionFVInfo` deflt_fvs,
- alts_escs `unionVarSet` deflt_escs
- )
-
- where
- vars_prim_alt (LitAlt lit, _, rhs)
- = coreToStgExpr rhs `thenLne` \ (rhs2, rhs_fvs, rhs_escs) ->
- returnLne ((lit, rhs2), rhs_fvs, rhs_escs)
-
- vars_alg_alt (DataAlt con, binders, rhs)
- = let
- -- remove type variables
- binders' = filterStgBinders binders
- in
- extendVarEnvLne [(b, CaseBound) | b <- binders'] $
- coreToStgExpr rhs `thenLne` \ (rhs2, rhs_fvs, rhs_escs) ->
- let
- good_use_mask = [ b `elementOfFVInfo` rhs_fvs | b <- binders' ]
- -- records whether each param is used in the RHS
- in
- returnLne (
- (con, binders', good_use_mask, rhs2),
- binders' `minusFVBinders` rhs_fvs,
- rhs_escs `minusVarSet` mkVarSet binders'
- -- ToDo: remove the minusVarSet;
- -- since escs won't include any of these binders
- )
- vars_alg_alt other = pprPanic "vars_alg_alt" (ppr other)
-
- vars_deflt Nothing
- = returnLne (StgNoDefault, emptyFVInfo, emptyVarSet)
-
- vars_deflt (Just rhs)
- = coreToStgExpr rhs `thenLne` \ (rhs2, rhs_fvs, rhs_escs) ->
- returnLne (StgBindDefault rhs2, rhs_fvs, rhs_escs)
+ vars_alt (con, binders, rhs)
+ = let -- Remove type variables
+ binders' = filterStgBinders binders
+ in
+ extendVarEnvLne [(b, LambdaBound) | b <- binders'] $
+ coreToStgExpr rhs `thenLne` \ (rhs2, rhs_fvs, rhs_escs) ->
+ let
+ -- Records whether each param is used in the RHS
+ good_use_mask = [ b `elementOfFVInfo` rhs_fvs | b <- binders' ]
+ in
+ returnLne ( (con, binders', good_use_mask, rhs2),
+ binders' `minusFVBinders` rhs_fvs,
+ rhs_escs `delVarSetList` binders' )
+ -- ToDo: remove the delVarSet;
+ -- since escs won't include any of these binders
\end{code}
Lets not only take quite a bit of work, but this is where we convert
\end{code}
\begin{code}
-mkStgAlgAlts ty alts deflt
- = case alts of
- -- Get the tycon from the data con
- (dc, _, _, _) : _rest
- -> StgAlgAlts (Just (dataConTyCon dc)) alts deflt
-
- -- Otherwise just do your best
- [] -> case splitTyConApp_maybe (repType ty) of
- Just (tc,_) | isAlgTyCon tc
- -> StgAlgAlts (Just tc) alts deflt
- other
- -> StgAlgAlts Nothing alts deflt
-
-mkStgPrimAlts ty alts deflt
- = StgPrimAlts (tyConAppTyCon ty) alts deflt
+mkStgAlts scrut_ty orig_alts
+ | is_prim_case = StgPrimAlts (tyConAppTyCon scrut_ty) prim_alts deflt
+ | otherwise = StgAlgAlts maybe_tycon alg_alts deflt
+ where
+ is_prim_case = isUnLiftedType scrut_ty && not (isUnboxedTupleType scrut_ty)
+
+ prim_alts = [(lit, rhs) | (LitAlt lit, _, _, rhs) <- other_alts]
+ alg_alts = [(con, bndrs, use, rhs) | (DataAlt con, bndrs, use, rhs) <- other_alts]
+
+ (other_alts, deflt)
+ = case orig_alts of -- DEFAULT is always first if it's there at all
+ (DEFAULT, _, _, rhs) : other_alts -> (other_alts, StgBindDefault rhs)
+ other -> (orig_alts, StgNoDefault)
+
+ maybe_tycon = case alg_alts of
+ -- Get the tycon from the data con
+ (dc, _, _, _) : _rest -> Just (dataConTyCon dc)
+
+ -- Otherwise just do your best
+ [] -> case splitTyConApp_maybe (repType scrut_ty) of
+ Just (tc,_) | isAlgTyCon tc -> Just tc
+ _other -> Nothing
\end{code}
-- let f = \ab -> e in f
-- No point in having correct arity info for f!
-- Hence the hasArity stuff below.
+ -- NB: f_arity is only consulted for LetBound things
f_arity = case how_bound of
- LetBound _ _ arity -> arity
- _ -> 0
+ LetBound _ arity -> arity
fun_occ
| not_letrec_bound = noBinderInfo -- Uninteresting variable
-- is among the escaping vars
coreToStgLet let_no_escape bind body
- = fixLne (\ ~(_, _, _, _, _, _, rec_body_fvs, _, _) ->
+ = fixLne (\ ~(_, _, _, _, _, rec_body_fvs, _, _) ->
-- Do the bindings, setting live_in_cont to empty if
-- we ain't in a let-no-escape world
getVarsLiveInCont `thenLne` \ live_in_cont ->
setVarsLiveInCont (if let_no_escape
then live_in_cont
- else emptyLVS)
+ else emptyLiveInfo)
(vars_bind rec_body_fvs bind)
- `thenLne` \ ( bind2, bind_fvs, bind_escs
- , bind_lvs, bind_cafs, env_ext) ->
+ `thenLne` \ ( bind2, bind_fvs, bind_escs, bind_lv_info, env_ext) ->
-- Do the body
extendVarEnvLne env_ext (
coreToStgExpr body `thenLne` \(body2, body_fvs, body_escs) ->
- freeVarsToLiveVars body_fvs `thenLne` \(body_lvs, _) ->
+ freeVarsToLiveVars body_fvs `thenLne` \ body_lv_info ->
- returnLne (bind2, bind_fvs, bind_escs, bind_lvs, bind_cafs,
- body2, body_fvs, body_escs, body_lvs)
+ returnLne (bind2, bind_fvs, bind_escs, getLiveVars bind_lv_info,
+ body2, body_fvs, body_escs, getLiveVars body_lv_info)
)
- ) `thenLne` (\ (bind2, bind_fvs, bind_escs, bind_lvs, bind_cafs,
+ ) `thenLne` (\ (bind2, bind_fvs, bind_escs, bind_lvs,
body2, body_fvs, body_escs, body_lvs) ->
= binders `minusFVBinders` (bind_fvs `unionFVInfo` body_fvs)
live_in_whole_let
- = bind_lvs `unionVarSet` (body_lvs `minusVarSet` set_of_binders)
+ = bind_lvs `unionVarSet` (body_lvs `delVarSetList` binders)
real_bind_escs = if let_no_escape then
bind_escs
getFVSet bind_fvs
-- Everything escapes which is free in the bindings
- let_escs = (real_bind_escs `unionVarSet` body_escs) `minusVarSet` set_of_binders
+ let_escs = (real_bind_escs `unionVarSet` body_escs) `delVarSetList` binders
all_escs = bind_escs `unionVarSet` body_escs -- Still includes binders of
-- this let(rec)
))
where
set_of_binders = mkVarSet binders
- binders = case bind of
- NonRec binder rhs -> [binder]
- Rec pairs -> map fst pairs
+ binders = bindersOf bind
- mk_binding bind_lvs bind_cafs binder rhs
- = (binder, LetBound NotTopLevelBound -- Not top level
- live_vars (predictArity rhs)
- )
+ mk_binding bind_lv_info binder rhs
+ = (binder, LetBound (NestedLet live_vars) (predictArity rhs))
where
- live_vars = if let_no_escape then
- (extendVarSet bind_lvs binder, bind_cafs)
- else
- (unitVarSet binder, emptyVarSet)
+ live_vars | let_no_escape = addLiveVar bind_lv_info binder
+ | otherwise = unitLiveVar binder
+ -- c.f. the invariant on NestedLet
vars_bind :: FreeVarsInfo -- Free var info for body of binding
-> CoreBind
-> LneM (StgBinding,
FreeVarsInfo,
EscVarsSet, -- free vars; escapee vars
- StgLiveVars, -- vars live in binding
- IdSet, -- CAFs live in binding
+ LiveInfo, -- Vars and CAFs live in binding
[(Id, HowBound)]) -- extension to environment
= coreToStgRhs body_fvs NotTopLevel (binder,rhs)
`thenLne` \ (rhs2, bind_fvs, escs) ->
- freeVarsToLiveVars bind_fvs `thenLne` \ (bind_lvs, bind_cafs) ->
+ freeVarsToLiveVars bind_fvs `thenLne` \ bind_lv_info ->
let
- env_ext_item = mk_binding bind_lvs bind_cafs binder rhs
+ env_ext_item = mk_binding bind_lv_info binder rhs
in
- returnLne (StgNonRec (SRTEntries bind_cafs) binder rhs2,
- bind_fvs, escs, bind_lvs, bind_cafs, [env_ext_item])
+ returnLne (StgNonRec (mkSRT bind_lv_info) binder rhs2,
+ bind_fvs, escs, bind_lv_info, [env_ext_item])
vars_bind body_fvs (Rec pairs)
- = fixLne (\ ~(_, rec_rhs_fvs, _, bind_lvs, bind_cafs, _) ->
+ = fixLne (\ ~(_, rec_rhs_fvs, _, bind_lv_info, _) ->
let
rec_scope_fvs = unionFVInfo body_fvs rec_rhs_fvs
binders = map fst pairs
- env_ext = [ mk_binding bind_lvs bind_cafs b rhs
+ env_ext = [ mk_binding bind_lv_info b rhs
| (b,rhs) <- pairs ]
in
extendVarEnvLne env_ext (
escs = unionVarSets escss
in
freeVarsToLiveVars (binders `minusFVBinders` bind_fvs)
- `thenLne` \ (bind_lvs, bind_cafs) ->
+ `thenLne` \ bind_lv_info ->
- returnLne (StgRec (SRTEntries bind_cafs) (binders `zip` rhss2),
- bind_fvs, escs, bind_lvs, bind_cafs, env_ext)
+ returnLne (StgRec (mkSRT bind_lv_info) (binders `zip` rhss2),
+ bind_fvs, escs, bind_lv_info, env_ext)
)
)
\begin{code}
type LneM a = IdEnv HowBound
- -> (StgLiveVars, -- vars live in continuation
- IdSet) -- cafs live in continuation
+ -> LiveInfo -- Vars and CAFs live in continuation
-> a
+type LiveInfo = (StgLiveVars, -- Dynamic live variables;
+ -- i.e. ones with a nested (non-top-level) binding
+ CafSet) -- Static live variables;
+ -- i.e. top-level variables that are CAFs or refer to them
+
+type EscVarsSet = IdSet
+type CafSet = IdSet
+
data HowBound
= ImportBound -- Used only as a response to lookupBinding; never
-- exists in the range of the (IdEnv HowBound)
- | CaseBound
- | LambdaBound
- | LetBound
- TopLevelCafInfo
- (StgLiveVars, IdSet) -- (Live vars, Live CAFs)... see notes below
- Arity -- its arity (local Ids don't have arity info at this point)
-
-isLetBound (LetBound _ _ _) = True
-isLetBound other = False
+
+ | LetBound -- A let(rec) in this module
+ LetInfo -- Whether top level or nested
+ Arity -- Its arity (local Ids don't have arity info at this point)
+
+ | LambdaBound -- Used for both lambda and case
+
+data LetInfo = NestedLet LiveInfo -- For nested things, what is live if this thing is live?
+ -- Invariant: the binder itself is always a member of
+ -- the dynamic set of its own LiveInfo
+ | TopLet CafInfo -- For top level things, is it a CAF, or can it refer to one?
+
+isLetBound (LetBound _ _) = True
+isLetBound other = False
+
+topLevelBound ImportBound = True
+topLevelBound (LetBound (TopLet _) _) = True
+topLevelBound other = False
\end{code}
-For a let(rec)-bound variable, x, we record StgLiveVars, the set of
-variables that are live if x is live. For "normal" variables that is
-just x alone. If x is a let-no-escaped variable then x is represented
-by a code pointer and a stack pointer (well, one for each stack). So
-all of the variables needed in the execution of x are live if x is,
-and are therefore recorded in the LetBound constructor; x itself
-*is* included.
+For a let(rec)-bound variable, x, we record LiveInfo, the set of
+variables that are live if x is live. This LiveInfo comprises
+ (a) dynamic live variables (ones with a non-top-level binding)
+ (b) static live variabes (CAFs or things that refer to CAFs)
-The set of live variables is guaranteed ot have no further let-no-escaped
+For "normal" variables (a) is just x alone. If x is a let-no-escaped
+variable then x is represented by a code pointer and a stack pointer
+(well, one for each stack). So all of the variables needed in the
+execution of x are live if x is, and are therefore recorded in the
+LetBound constructor; x itself *is* included.
+
+The set of dynamic live variables is guaranteed ot have no further let-no-escaped
variables in it.
+\begin{code}
+emptyLiveInfo :: LiveInfo
+emptyLiveInfo = (emptyVarSet,emptyVarSet)
+
+unitLiveVar :: Id -> LiveInfo
+unitLiveVar lv = (unitVarSet lv, emptyVarSet)
+
+unitLiveCaf :: Id -> LiveInfo
+unitLiveCaf caf = (emptyVarSet, unitVarSet caf)
+
+addLiveVar :: LiveInfo -> Id -> LiveInfo
+addLiveVar (lvs, cafs) id = (lvs `extendVarSet` id, cafs)
+
+deleteLiveVar :: LiveInfo -> Id -> LiveInfo
+deleteLiveVar (lvs, cafs) id = (lvs `delVarSet` id, cafs)
+
+unionLiveInfo :: LiveInfo -> LiveInfo -> LiveInfo
+unionLiveInfo (lv1,caf1) (lv2,caf2) = (lv1 `unionVarSet` lv2, caf1 `unionVarSet` caf2)
+
+unionLiveInfos :: [LiveInfo] -> LiveInfo
+unionLiveInfos lvs = foldr unionLiveInfo emptyLiveInfo lvs
+
+mkSRT :: LiveInfo -> SRT
+mkSRT (_, cafs) = SRTEntries cafs
+
+getLiveVars :: LiveInfo -> StgLiveVars
+getLiveVars (lvs, _) = lvs
+\end{code}
+
+
The std monad functions:
\begin{code}
initLne :: IdEnv HowBound -> LneM a -> a
-initLne env m = m env emptyLVS
+initLne env m = m env emptyLiveInfo
+
-emptyLVS = (emptyVarSet,emptyVarSet)
{-# INLINE thenLne #-}
{-# INLINE returnLne #-}
Functions specific to this monad:
\begin{code}
-getVarsLiveInCont :: LneM (StgLiveVars, IdSet)
+getVarsLiveInCont :: LneM LiveInfo
getVarsLiveInCont env lvs_cont = lvs_cont
-setVarsLiveInCont :: (StgLiveVars,IdSet) -> LneM a -> LneM a
+setVarsLiveInCont :: LiveInfo -> LneM a -> LneM a
setVarsLiveInCont new_lvs_cont expr env lvs_cont
= expr env new_lvs_cont
-- only ever tacked onto a decorated expression. It is never used as
-- the basis of a control decision, which might give a black hole.
-freeVarsToLiveVars :: FreeVarsInfo -> LneM (StgLiveVars, IdSet)
+freeVarsToLiveVars :: FreeVarsInfo -> LneM LiveInfo
freeVarsToLiveVars fvs env live_in_cont
- = returnLne (lvs, cafs) env live_in_cont
+ = returnLne live_info env live_in_cont
where
- (lvs_cont, cafs_cont) = live_in_cont -- not a strict pattern match!
-
- (lvs_from_fvs, caf_from_fvs) = unzip (map do_one (allFreeIds fvs))
-
- lvs = unionVarSets lvs_from_fvs `unionVarSet` lvs_cont
- cafs = unionVarSets caf_from_fvs `unionVarSet` cafs_cont
+ live_info = foldr unionLiveInfo live_in_cont lvs_from_fvs
+ lvs_from_fvs = map do_one (allFreeIds fvs)
- do_one v
- = case lookupBinding env v of
- LetBound caf_ness (lvs,cafs) _ ->
- case caf_ness of
- TopLevelHasCafs -> ASSERT( isEmptyVarSet lvs ) (emptyVarSet, unitVarSet v)
- TopLevelNoCafs -> ASSERT( isEmptyVarSet lvs ) (emptyVarSet, emptyVarSet)
- NotTopLevelBound -> (extendVarSet lvs v, cafs)
+ do_one (v, how_bound)
+ = case how_bound of
+ ImportBound -> unitLiveCaf v -- Only CAF imports are
+ -- recorded in fvs
+ LetBound (TopLet caf_info) _
+ | mayHaveCafRefs caf_info -> unitLiveCaf v
+ | otherwise -> emptyLiveInfo
- ImportBound | mayHaveCafRefs (idCafInfo v) -> (emptyVarSet, unitVarSet v)
- | otherwise -> (emptyVarSet, emptyVarSet)
+ LetBound (NestedLet lvs) _ -> lvs -- lvs already contains v
+ -- (see the invariant on NestedLet)
- _nested_binding -> (unitVarSet v, emptyVarSet) -- Bound by lambda or case
+ _lambda_or_case_binding -> unitLiveVar v -- Bound by lambda or case
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-type FreeVarsInfo = VarEnv (Var, TopLevelCafInfo, StgBinderInfo)
+type FreeVarsInfo = VarEnv (Var, HowBound, StgBinderInfo)
+ -- The Var is so we can gather up the free variables
+ -- as a set.
+ --
+ -- The HowBound info just saves repeated lookups;
+ -- we look up just once when we encounter the occurrence.
+ -- INVARIANT: Any ImportBound Ids are HaveCafRef Ids
+ -- Imported Ids without CAF refs are simply
+ -- not put in the FreeVarsInfo for an expression;
+ -- see singletonFVInfo
+ --
+ -- StgBinderInfo
-- If f is mapped to noBinderInfo, that means
-- that f *is* mentioned (else it wouldn't be in the
-- IdEnv at all), but perhaps in an unsaturated applications.
--
-- For ILX we track free var info for type variables too;
-- hence VarEnv not IdEnv
-
-data TopLevelCafInfo
- = NotTopLevelBound
- | TopLevelNoCafs
- | TopLevelHasCafs
- deriving Eq
-
-type EscVarsSet = IdSet
\end{code}
\begin{code}
emptyFVInfo = emptyVarEnv
singletonFVInfo :: Id -> HowBound -> StgBinderInfo -> FreeVarsInfo
+-- Don't record non-CAF imports at all, to keep free-var sets small
singletonFVInfo id ImportBound info
- | mayHaveCafRefs (idCafInfo id) = unitVarEnv id (id, TopLevelHasCafs, info)
+ | mayHaveCafRefs (idCafInfo id) = unitVarEnv id (id, ImportBound, info)
| otherwise = emptyVarEnv
-singletonFVInfo id (LetBound top_level _ _) info
- = unitVarEnv id (id, top_level, info)
-singletonFVInfo id other info
- = unitVarEnv id (id, NotTopLevelBound, info)
+singletonFVInfo id how_bound info = unitVarEnv id (id, how_bound, info)
tyvarFVInfo :: TyVarSet -> FreeVarsInfo
tyvarFVInfo tvs = foldVarSet add emptyFVInfo tvs
where
- add tv fvs = extendVarEnv fvs tv (tv, NotTopLevelBound, noBinderInfo)
+ add tv fvs = extendVarEnv fvs tv (tv, LambdaBound, noBinderInfo)
+ -- Type variables must be lambda-bound
unionFVInfo :: FreeVarsInfo -> FreeVarsInfo -> FreeVarsInfo
unionFVInfo fv1 fv2 = plusVarEnv_C plusFVInfo fv1 fv2
Nothing -> noBinderInfo
Just (_,_,info) -> info
-allFreeIds :: FreeVarsInfo -> [Id] -- Non-top-level things only
-allFreeIds fvs = [id | (id,_,_) <- rngVarEnv fvs, isId id]
+allFreeIds :: FreeVarsInfo -> [(Id,HowBound)] -- Both top level and non-top-level Ids
+allFreeIds fvs = [(id,how_bound) | (id,how_bound,_) <- rngVarEnv fvs, isId id]
--- Non-top-level things only, both type variables and ids (type variables
--- only if opt_RuntimeTypes.
+-- Non-top-level things only, both type variables and ids
+-- (type variables only if opt_RuntimeTypes)
getFVs :: FreeVarsInfo -> [Var]
-getFVs fvs = [id | (id,NotTopLevelBound,_) <- rngVarEnv fvs]
+getFVs fvs = [id | (id, how_bound, _) <- rngVarEnv fvs,
+ not (topLevelBound how_bound) ]
getFVSet :: FreeVarsInfo -> VarSet
getFVSet fvs = mkVarSet (getFVs fvs)
-plusFVInfo (id1,top1,info1) (id2,top2,info2)
- = ASSERT (id1 == id2 && top1 == top2)
- (id1, top1, combineStgBinderInfo info1 info2)
+plusFVInfo (id1,hb1,info1) (id2,hb2,info2)
+ = ASSERT (id1 == id2 && hb1 `check_eq_how_bound` hb2)
+ (id1, hb1, combineStgBinderInfo info1 info2)
+
+#ifdef DEBUG
+-- The HowBound info for a variable in the FVInfo should be consistent
+check_eq_how_bound ImportBound ImportBound = True
+check_eq_how_bound LambdaBound LambdaBound = True
+check_eq_how_bound (LetBound li1 ar1) (LetBound li2 ar2) = ar1 == ar2 && check_eq_li li1 li2
+check_eq_how_bound hb1 hb2 = False
+
+check_eq_li (NestedLet _) (NestedLet _) = True
+check_eq_li (TopLet _) (TopLet _) = True
+check_eq_li li1 li2 = False
+#endif
\end{code}
Misc.
cafRefs p (Var id)
= case lookupVarEnv p id of
- Just (LetBound TopLevelHasCafs _ _) -> fastBool True -- Top level
- Just (LetBound TopLevelNoCafs _ _) -> fastBool False -- Top level
- Nothing | isLocalId id -> fastBool False -- Nested binder
- | otherwise -> fastBool (mayHaveCafRefs (idCafInfo id)) -- Imported
- Just _other -> error ("cafRefs " ++ showSDoc (ppr id)) -- No nested things in env
-
+ Just (LetBound (TopLet caf_info) _) -> fastBool (mayHaveCafRefs caf_info)
+ Nothing | isGlobalId id -> fastBool (mayHaveCafRefs (idCafInfo id)) -- Imported
+ | otherwise -> fastBool False -- Nested binder
+ _other -> error ("cafRefs " ++ showSDoc (ppr id)) -- No nested things in env
cafRefs p (Lit l) = fastBool False
cafRefs p (App f a) = fastOr (cafRefs p f) (cafRefs p) a
cafRefs p (Lam x e) = cafRefs p e
cafRefs p (Let b e) = fastOr (cafRefss p (rhssOfBind b)) (cafRefs p) e
-cafRefs p (Case e bndr alts) = fastOr (cafRefs p e)
- (cafRefss p) (rhssOfAlts alts)
+cafRefs p (Case e bndr alts) = fastOr (cafRefs p e) (cafRefss p) (rhssOfAlts alts)
cafRefs p (Note n e) = cafRefs p e
cafRefs p (Type t) = fastBool False
projects / ghc-hetmet.git / commitdiff