#include "HsVersions.h"
import CoreSyn
-import CoreFVs
import CoreUtils
-import SimplUtils
import StgSyn
import Type
import TyCon ( isAlgTyCon )
+import Literal
import Id
+import Var ( Var, globalIdDetails, varType )
import IdInfo
import DataCon
import CostCentre ( noCCS )
import VarEnv
import DataCon ( dataConWrapId )
import IdInfo ( OccInfo(..) )
-import PrimOp ( PrimOp(..), ccallMayGC )
-import TysPrim ( foreignObjPrimTyCon )
-import Maybes ( maybeToBool, orElse )
-import Name ( getOccName )
-import Module ( Module )
+import Maybes ( maybeToBool )
+import Name ( getOccName, isExternallyVisibleName, isDllName )
import OccName ( occNameUserString )
-import BasicTypes ( TopLevelFlag(..), isNotTopLevel )
-import CmdLineOpts ( DynFlags )
+import BasicTypes ( TopLevelFlag(..), isNotTopLevel, Arity )
+import CmdLineOpts ( DynFlags, opt_RuntimeTypes )
+import FastTypes hiding ( fastOr )
import Outputable
-infixr 9 `thenLne`, `thenLne_`
+import List ( partition )
+
+infixr 9 `thenLne`
\end{code}
%************************************************************************
%************************************************************************
%* *
+\subsection[caf-info]{Collecting live CAF info}
+%* *
+%************************************************************************
+
+In this pass we also collect information on which CAFs are live for
+constructing SRTs (see SRT.lhs).
+
+A top-level Id has CafInfo, which is
+
+ - MayHaveCafRefs, if it may refer indirectly to
+ one or more CAFs, or
+ - NoCafRefs if it definitely doesn't
+
+we collect the CafInfo first by analysing the original Core expression, and
+also place this information in the environment.
+
+During CoreToStg, we then pin onto each binding and case expression, a
+list of Ids which represents the "live" CAFs at that point. The meaning
+of "live" here is the same as for live variables, see above (which is
+why it's convenient to collect CAF information here rather than elsewhere).
+
+The later SRT pass takes these lists of Ids and uses them to construct
+the actual nested SRTs, and replaces the lists of Ids with (offset,length)
+pairs.
+
+%************************************************************************
+%* *
\subsection[binds-StgVarInfo]{Setting variable info: top-level, binds, RHSs}
%* *
%************************************************************************
\begin{code}
-coreToStg :: DynFlags -> Module -> [CoreBind] -> IO [StgBinding]
-coreToStg dflags this_mod pgm
- = return (fst (initLne (coreTopBindsToStg pgm)))
+coreToStg :: DynFlags -> [CoreBind] -> IO [StgBinding]
+coreToStg dflags pgm
+ = return pgm'
+ where (_, _, pgm') = coreTopBindsToStg emptyVarEnv pgm
coreExprToStg :: CoreExpr -> StgExpr
coreExprToStg expr
- = new_expr where (new_expr,_,_) = initLne (coreToStgExpr expr)
-
--- For top-level guys, we basically aren't worried about this
--- live-variable stuff; we do need to keep adding to the environment
--- as we step through the bindings (using @extendVarEnv@).
-
-coreTopBindsToStg :: [CoreBind] -> LneM ([StgBinding], FreeVarsInfo)
-
-coreTopBindsToStg [] = returnLne ([], emptyFVInfo)
-coreTopBindsToStg (bind:binds)
- = let
- binders = bindersOf bind
- env_extension = binders `zip` repeat how_bound
- how_bound = LetrecBound True {- top level -}
- emptyVarSet
- in
-
- extendVarEnvLne env_extension (
- coreTopBindsToStg binds `thenLne` \ (binds', fv_binds) ->
- coreTopBindToStg binders fv_binds bind `thenLne` \ (bind', fv_bind) ->
- returnLne (
- (bind' : binds'),
- (fv_binds `unionFVInfo` fv_bind) `minusFVBinders` binders
- )
- )
+ = new_expr where (new_expr,_,_) = initLne emptyVarEnv (coreToStgExpr expr)
+
+
+coreTopBindsToStg
+ :: IdEnv HowBound -- environment for the bindings
+ -> [CoreBind]
+ -> (IdEnv HowBound, FreeVarsInfo, [StgBinding])
+
+coreTopBindsToStg env [] = (env, emptyFVInfo, [])
+coreTopBindsToStg env (b:bs)
+ = (env2, fvs2, b':bs')
+ where
+ -- env accumulates down the list of binds, fvs accumulates upwards
+ (env1, fvs2, b' ) = coreTopBindToStg env fvs1 b
+ (env2, fvs1, bs') = coreTopBindsToStg env1 bs
coreTopBindToStg
- :: [Id] -- New binders (with correct arity)
+ :: IdEnv HowBound
-> FreeVarsInfo -- Info about the body
-> CoreBind
- -> LneM (StgBinding, FreeVarsInfo)
+ -> (IdEnv HowBound, FreeVarsInfo, StgBinding)
-coreTopBindToStg [binder] body_fvs (NonRec _ rhs)
- = coreToStgRhs body_fvs TopLevel (binder,rhs) `thenLne` \ (rhs2, fvs, _) ->
- returnLne (StgNonRec binder rhs2, fvs)
+coreTopBindToStg env body_fvs (NonRec id rhs)
+ = let
+ caf_info = hasCafRefs env rhs
-coreTopBindToStg binders body_fvs (Rec pairs)
- = fixLne (\ ~(_, rec_rhs_fvs) ->
- let scope_fvs = unionFVInfo body_fvs rec_rhs_fvs
- in
- mapAndUnzip3Lne (coreToStgRhs scope_fvs TopLevel) pairs
- `thenLne` \ (rhss2, fvss, _) ->
- let fvs = unionFVInfos fvss
- in
- returnLne (StgRec (binders `zip` rhss2), fvs)
- )
+ env' = extendVarEnv env id (LetBound how_bound emptyLVS (predictArity rhs))
+
+ how_bound | mayHaveCafRefs caf_info = TopLevelHasCafs
+ | otherwise = TopLevelNoCafs
+
+ (stg_rhs, fvs', cafs) =
+ initLne env (
+ coreToStgRhs body_fvs TopLevel (id,rhs)
+ `thenLne` \ (stg_rhs, fvs', _) ->
+ freeVarsToLiveVars fvs' `thenLne` \ (_, cafs) ->
+ returnLne (stg_rhs, fvs', cafs)
+ )
+
+ bind = StgNonRec (SRTEntries cafs) id stg_rhs
+ in
+ ASSERT2(predictArity rhs == stgRhsArity stg_rhs, ppr id)
+ ASSERT2(consistent caf_info bind, ppr id)
+-- WARN(not (consistent caf_info bind), ppr id <+> ppr cafs <+> ppCafInfo caf_info)
+ (env', fvs' `unionFVInfo` body_fvs, bind)
+
+coreTopBindToStg env body_fvs (Rec pairs)
+ = let
+ (binders, rhss) = unzip pairs
+
+ -- to calculate caf_info, we initially map all the binders to
+ -- TopLevelNoCafs.
+ env1 = extendVarEnvList env
+ [ (b, LetBound TopLevelNoCafs emptyLVS (error "no arity"))
+ | b <- binders ]
+
+ caf_info = hasCafRefss env1{-NB: not env'-} rhss
+
+ env' = extendVarEnvList env
+ [ (b, LetBound how_bound emptyLVS (predictArity rhs))
+ | (b,rhs) <- pairs ]
+
+ how_bound | mayHaveCafRefs caf_info = TopLevelHasCafs
+ | otherwise = TopLevelNoCafs
+
+ (stg_rhss, fvs', cafs)
+ = 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)
+ )
+
+ bind = StgRec (SRTEntries cafs) (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)
+-- WARN(not (consistent caf_info bind), ppr binders <+> ppr cafs <+> ppCafInfo caf_info)
+ (env', fvs' `unionFVInfo` body_fvs, bind)
+
+-- assertion helper
+consistent caf_info bind = mayHaveCafRefs caf_info == stgBindHasCafRefs bind
\end{code}
\begin{code}
coreToStgRhs scope_fv_info top (binder, rhs)
= coreToStgExpr rhs `thenLne` \ (new_rhs, rhs_fvs, rhs_escs) ->
- case new_rhs of
-
- StgLam _ bndrs body
- -> let binder_info = lookupFVInfo scope_fv_info binder
- in returnLne (StgRhsClosure noCCS
- binder_info
- noSRT
- (getFVs rhs_fvs)
- ReEntrant
- bndrs
- body,
- rhs_fvs, rhs_escs)
+ returnLne (mkStgRhs top rhs_fvs binder_info new_rhs,
+ rhs_fvs, rhs_escs)
+ where
+ binder_info = lookupFVInfo scope_fv_info binder
+
+mkStgRhs :: TopLevelFlag -> FreeVarsInfo -> StgBinderInfo
+ -> StgExpr -> StgRhs
+
+mkStgRhs top rhs_fvs binder_info (StgLam _ bndrs body)
+ = StgRhsClosure noCCS binder_info
+ (getFVs rhs_fvs)
+ ReEntrant
+ bndrs body
- StgConApp con args
- | isNotTopLevel top || not (isDllConApp con args)
- -> returnLne (StgRhsCon noCCS con args, rhs_fvs, rhs_escs)
-
- _other_expr
- -> let binder_info = lookupFVInfo scope_fv_info binder
- in returnLne (StgRhsClosure noCCS
- binder_info
- noSRT
- (getFVs rhs_fvs)
- (updatable [] new_rhs)
- []
- new_rhs,
- rhs_fvs, rhs_escs
- )
-
-updatable args body | null args && isPAP body = ReEntrant
- | otherwise = Updatable
+mkStgRhs top rhs_fvs binder_info (StgConApp con args)
+ | isNotTopLevel top || not (isDllConApp con args)
+ = StgRhsCon noCCS con args
+
+mkStgRhs top rhs_fvs binder_info rhs
+ = StgRhsClosure noCCS binder_info
+ (getFVs rhs_fvs)
+ (updatable [] rhs)
+ [] rhs
+ where
+ updatable args body | null args && isPAP body = ReEntrant
+ | otherwise = Updatable
{- ToDo:
upd = if isOnceDem dem
then (if isNotTop toplev
\begin{code}
isPAP (StgApp f args) = idArity f > length args
isPAP _ = False
+\end{code}
--- ---------------------------------------------------------------------------
--- Atoms
--- ---------------------------------------------------------------------------
-
-coreToStgAtoms :: [CoreArg] -> LneM ([StgArg], FreeVarsInfo)
-coreToStgAtoms atoms
- = let val_atoms = filter isValArg atoms in
- mapAndUnzipLne coreToStgAtom val_atoms `thenLne` \ (args', fvs_lists) ->
- returnLne (args', unionFVInfos fvs_lists)
- where
- coreToStgAtom e
- = coreToStgExpr e `thenLne` \ (expr, fvs, escs) ->
- case expr of
- StgApp v [] -> returnLne (StgVarArg v, fvs)
- StgConApp con [] -> returnLne (StgVarArg (dataConWrapId con), fvs)
- StgLit lit -> returnLne (StgLitArg lit, fvs)
- _ -> pprPanic "coreToStgAtom" (ppr expr)
-- ---------------------------------------------------------------------------
-- Expressions
-- ---------------------------------------------------------------------------
-{-
-@varsExpr@ carries in a monad-ised environment, which binds each
-let(rec) variable (ie non top level, not imported, not lambda bound,
-not case-alternative bound) to:
- - its STG arity, and
- - its set of live vars.
-For normal variables the set of live vars is just the variable
-itself. For let-no-escaped variables, the set of live vars is the set
-live at the moment the variable is entered. The set is guaranteed to
-have no further let-no-escaped vars in it.
--}
-
+\begin{code}
coreToStgExpr
:: CoreExpr
-> LneM (StgExpr, -- Decorated STG expr
decisions. Hence no black holes.
\begin{code}
-coreToStgExpr (Lit l) = returnLne (StgLit l, emptyFVInfo, emptyVarSet)
-
-coreToStgExpr (Var v)
- = coreToStgApp Nothing v []
+coreToStgExpr (Lit l) = returnLne (StgLit l, emptyFVInfo, emptyVarSet)
+coreToStgExpr (Var v) = coreToStgApp Nothing v []
coreToStgExpr expr@(App _ _)
- = let (f, args) = myCollectArgs expr
- in
- coreToStgApp Nothing (shouldBeVar f) args
+ = coreToStgApp Nothing f args
+ where
+ (f, args) = myCollectArgs expr
coreToStgExpr expr@(Lam _ _)
= let (args, body) = myCollectBinders expr
- args' = filter isId args
+ args' = filterStgBinders args
in
extendVarEnvLne [ (a, LambdaBound) | a <- args' ] $
coreToStgExpr body `thenLne` \ (body, body_fvs, body_escs) ->
let
set_of_args = mkVarSet args'
- fvs = body_fvs `minusFVBinders` args'
+ fvs = args' `minusFVBinders` body_fvs
escs = body_escs `minusVarSet` set_of_args
+ result_expr | null args' = body
+ | otherwise = StgLam (exprType expr) args' body
in
- if null args'
- then returnLne (body, fvs, escs)
- else returnLne (StgLam (exprType expr) args' body, fvs, escs)
+ returnLne (result_expr, fvs, escs)
coreToStgExpr (Note (SCC cc) expr)
= coreToStgExpr expr `thenLne` ( \ (expr2, fvs, escs) ->
-- Cases require a little more real work.
coreToStgExpr (Case scrut bndr alts)
- = getVarsLiveInCont `thenLne` \ live_in_cont ->
- extendVarEnvLne [(bndr, CaseBound)] $
- vars_alts (findDefault alts) `thenLne` \ (alts2, alts_fvs, alts_escs) ->
- lookupLiveVarsForSet alts_fvs `thenLne` \ alts_lvs ->
+ = extendVarEnvLne [(bndr, CaseBound)] $
+ vars_alts (findDefault alts) `thenLne` \ (alts2, alts_fvs, alts_escs) ->
+ freeVarsToLiveVars alts_fvs `thenLne` \ (alts_lvs, alts_caf_refs) ->
let
-- 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 `setIdOccInfo` NoOccInfo
+ then bndr
else bndr `setIdOccInfo` IAmDead
- -- for a _ccall_GC_, some of the *arguments* need to live across the
- -- call (see findLiveArgs comments.), so we annotate them as being live
- -- in the alts to achieve the desired effect.
- mb_live_across_case =
- case scrut of
- -- ToDo: Notes?
- e@(App _ _) | (Var v, args) <- myCollectArgs e,
- PrimOpId (CCallOp ccall) <- idFlavour v,
- ccallMayGC ccall
- -> Just (filterVarSet isForeignObjArg (exprFreeVars e))
- _ -> Nothing
-
-- 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 = orElse (FMAP unionVarSet mb_live_across_case) id $
- live_in_cont `unionVarSet`
- (alts_lvs `minusVarSet` unitVarSet bndr)
+ live_in_alts = (alts_lvs `minusVarSet` unitVarSet bndr)
in
-- we tell the scrutinee that everything live in the alts
-- is live in it, too.
- setVarsLiveInCont live_in_alts (
- coreToStgExpr scrut
- ) `thenLne` \ (scrut2, scrut_fvs, scrut_escs) ->
-
- lookupLiveVarsForSet scrut_fvs `thenLne` \ scrut_lvs ->
- let
- live_in_whole_case = live_in_alts `unionVarSet` scrut_lvs
+ setVarsLiveInCont (live_in_alts,alts_caf_refs) (
+ coreToStgExpr scrut `thenLne` \ (scrut2, scrut_fvs, scrut_escs) ->
+ freeVarsToLiveVars scrut_fvs `thenLne` \ (scrut_lvs, _) ->
+ returnLne (scrut2, scrut_fvs, scrut_escs, scrut_lvs)
+ )
+ `thenLne` \ (scrut2, scrut_fvs, scrut_escs, scrut_lvs) ->
+
+ let srt = SRTEntries alts_caf_refs
in
returnLne (
- mkStgCase scrut2 live_in_whole_case live_in_alts bndr' noSRT alts2,
- (scrut_fvs `unionFVInfo` alts_fvs) `minusFVBinders` [bndr],
+ 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
- -- 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.
+ -- 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
vars_alg_alt (DataAlt con, binders, rhs)
= let
-- remove type variables
- binders' = filter isId binders
+ binders' = filterStgBinders binders
in
extendVarEnvLne [(b, CaseBound) | b <- binders'] $
coreToStgExpr rhs `thenLne` \ (rhs2, rhs_fvs, rhs_escs) ->
in
returnLne (
(con, binders', good_use_mask, rhs2),
- rhs_fvs `minusFVBinders` binders',
+ 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)
-
\end{code}
Lets not only take quite a bit of work, but this is where we convert
returnLne (new_let, fvs, escs)
\end{code}
-If we've got a case containing a _ccall_GC_ primop, we need to
-ensure that the arguments are kept live for the duration of the
-call. This only an issue
-
-\begin{code}
-isForeignObjArg :: Id -> Bool
-isForeignObjArg x = isId x && isForeignObjPrimTy (idType x)
-
-isForeignObjPrimTy ty
- = case splitTyConApp_maybe ty of
- Just (tycon, _) -> tycon == foreignObjPrimTyCon
- Nothing -> False
-\end{code}
-
\begin{code}
-mkStgCase scrut@(StgPrimApp ParOp _ _) lvs1 lvs2 bndr srt
- (StgPrimAlts tycon _ deflt@(StgBindDefault _))
- = StgCase scrut lvs1 lvs2 bndr srt (StgPrimAlts tycon [] deflt)
-
-mkStgCase (StgPrimApp SeqOp [scrut] _) lvs1 lvs2 bndr srt
- (StgPrimAlts _ _ deflt@(StgBindDefault rhs))
- = StgCase scrut_expr lvs1 lvs2 new_bndr srt new_alts
- where
- new_alts
- | isUnLiftedType scrut_ty = WARN( True, text "mkStgCase" )
- mkStgPrimAlts scrut_ty [] deflt
- | otherwise = mkStgAlgAlts scrut_ty [] deflt
-
- scrut_ty = stgArgType scrut
- new_bndr = setIdType bndr scrut_ty
- -- NB: SeqOp :: forall a. a -> Int#
- -- So bndr has type Int#
- -- But now we are going to scrutinise the SeqOp's argument directly,
- -- so we must change the type of the case binder to match that
- -- of the argument expression e.
-
- scrut_expr = case scrut of
- StgVarArg v -> StgApp v []
- -- Others should not happen because
- -- seq of a value should have disappeared
- StgLitArg l -> WARN( True, text "seq on" <+> ppr l ) StgLit l
-
-mkStgCase scrut lvs1 lvs2 bndr srt alts
- = StgCase scrut lvs1 lvs2 bndr srt alts
-
-
mkStgAlgAlts ty alts deflt
= case alts of
-- Get the tycon from the data con
\end{code}
-Applications:
+-- ---------------------------------------------------------------------------
+-- Applications
+-- ---------------------------------------------------------------------------
+
\begin{code}
coreToStgApp
:: Maybe UpdateFlag -- Just upd <=> this application is
-> LneM (StgExpr, FreeVarsInfo, EscVarsSet)
coreToStgApp maybe_thunk_body f args
- = getVarsLiveInCont `thenLne` \ live_in_cont ->
- coreToStgAtoms args `thenLne` \ (args', args_fvs) ->
+ = coreToStgArgs args `thenLne` \ (args', args_fvs) ->
lookupVarLne f `thenLne` \ how_bound ->
let
- n_args = length args
- not_letrec_bound = not (isLetrecBound how_bound)
- f_arity = idArity f
- fun_fvs = singletonFVInfo f how_bound fun_occ
+ n_val_args = valArgCount args
+ not_letrec_bound = not (isLetBound how_bound)
+ fun_fvs
+ = let fvs = singletonFVInfo f how_bound fun_occ in
+ -- e.g. (f :: a -> int) (x :: a)
+ -- Here the free variables are "f", "x" AND the type variable "a"
+ -- coreToStgArgs will deal with the arguments recursively
+ if opt_RuntimeTypes then
+ fvs `unionFVInfo` tyvarFVInfo (tyVarsOfType (varType f))
+ else fvs
+
+ -- Mostly, the arity info of a function is in the fn's IdInfo
+ -- But new bindings introduced by CoreSat may not have no
+ -- arity info; it would do us no good anyway. For example:
+ -- let f = \ab -> e in f
+ -- No point in having correct arity info for f!
+ -- Hence the hasArity stuff below.
+ f_arity = case how_bound of
+ LetBound _ _ arity -> arity
+ _ -> 0
fun_occ
- | not_letrec_bound = NoStgBinderInfo -- Uninteresting variable
-
- -- Otherwise it is letrec bound; must have its arity
- | n_args == 0 = stgFakeFunAppOcc -- Function Application
- -- with no arguments.
- -- used by the lambda lifter.
- | f_arity > n_args = stgUnsatOcc -- Unsaturated
-
- | f_arity == n_args &&
- maybeToBool maybe_thunk_body -- Exactly saturated,
- -- and rhs of thunk
- = case maybe_thunk_body of
- Just Updatable -> stgStdHeapOcc
- Just SingleEntry -> stgNoUpdHeapOcc
- other -> panic "coreToStgApp"
-
- | otherwise = stgNormalOcc
- -- Record only that it occurs free
-
- myself = unitVarSet f
-
- fun_escs | not_letrec_bound = emptyVarSet
- -- Only letrec-bound escapees are interesting
- | f_arity == n_args = emptyVarSet
- -- Function doesn't escape
- | otherwise = myself
- -- Inexact application; it does escape
+ | not_letrec_bound = noBinderInfo -- Uninteresting variable
+ | f_arity > 0 && f_arity <= n_val_args = stgSatOcc -- Saturated or over-saturated function call
+ | otherwise = stgUnsatOcc -- Unsaturated function or thunk
+
+ fun_escs
+ | not_letrec_bound = emptyVarSet -- Only letrec-bound escapees are interesting
+ | f_arity == n_val_args = emptyVarSet -- A function *or thunk* with an exactly
+ -- saturated call doesn't escape
+ -- (let-no-escape applies to 'thunks' too)
+
+ | otherwise = unitVarSet f -- Inexact application; it does escape
-- At the moment of the call:
-- continuation, but it does no harm to just union the
-- two regardless.
- -- XXX not needed?
- -- live_at_call
- -- = live_in_cont `unionVarSet` case how_bound of
- -- LetrecBound _ lvs -> lvs `minusVarSet` myself
- -- other -> emptyVarSet
-
- app = case idFlavour f of
- DataConId dc -> StgConApp dc args'
- PrimOpId op -> StgPrimApp op args' (exprType (mkApps (Var f) args))
+ res_ty = exprType (mkApps (Var f) args)
+ app = case globalIdDetails f of
+ DataConId dc -> StgConApp dc args'
+ PrimOpId op -> StgOpApp (StgPrimOp op) args' res_ty
+ FCallId call -> StgOpApp (StgFCallOp call (idUnique f)) args' res_ty
_other -> StgApp f args'
in
)
+
+-- ---------------------------------------------------------------------------
+-- Argument lists
+-- This is the guy that turns applications into A-normal form
+-- ---------------------------------------------------------------------------
+
+coreToStgArgs :: [CoreArg] -> LneM ([StgArg], FreeVarsInfo)
+coreToStgArgs []
+ = returnLne ([], emptyFVInfo)
+
+coreToStgArgs (Type ty : args) -- Type argument
+ = coreToStgArgs args `thenLne` \ (args', fvs) ->
+ if opt_RuntimeTypes then
+ returnLne (StgTypeArg ty : args', fvs `unionFVInfo` tyvarFVInfo (tyVarsOfType ty))
+ else
+ returnLne (args', fvs)
+
+coreToStgArgs (arg : args) -- Non-type argument
+ = coreToStgArgs args `thenLne` \ (stg_args, args_fvs) ->
+ coreToStgExpr arg `thenLne` \ (arg', arg_fvs, escs) ->
+ let
+ fvs = args_fvs `unionFVInfo` arg_fvs
+ stg_arg = case arg' of
+ StgApp v [] -> StgVarArg v
+ StgConApp con [] -> StgVarArg (dataConWrapId con)
+ StgLit lit -> StgLitArg lit
+ _ -> pprPanic "coreToStgArgs" (ppr arg)
+ in
+ returnLne (stg_arg : stg_args, fvs)
+
+
-- ---------------------------------------------------------------------------
-- The magic for lets:
-- ---------------------------------------------------------------------------
-- is among the escaping vars
coreToStgLet let_no_escape bind body
- = fixLne (\ ~(_, _, _, rec_bind_lvs, _, 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 emptyVarSet)
- (vars_bind rec_bind_lvs rec_body_fvs bind)
- `thenLne` \ (bind2, bind_fvs, bind_escs, env_ext) ->
-
- -- The live variables of this binding are the ones which are live
- -- by virtue of being accessible via the free vars of the binding (lvs_from_fvs)
- -- together with the live_in_cont ones
- lookupLiveVarsForSet (bind_fvs `minusFVBinders` binders)
- `thenLne` \ lvs_from_fvs ->
- let
- bind_lvs = lvs_from_fvs `unionVarSet` live_in_cont
- in
-
- -- bind_fvs and bind_escs still include the binders of the let(rec)
- -- but bind_lvs does not
+ setVarsLiveInCont (if let_no_escape
+ then live_in_cont
+ else emptyLVS)
+ (vars_bind rec_body_fvs bind)
+ `thenLne` \ ( bind2, bind_fvs, bind_escs
+ , bind_lvs, bind_cafs, env_ext) ->
-- Do the body
extendVarEnvLne env_ext (
- coreToStgExpr body `thenLne` \ (body2, body_fvs, body_escs) ->
- lookupLiveVarsForSet body_fvs `thenLne` \ body_lvs ->
+ coreToStgExpr body `thenLne` \(body2, body_fvs, body_escs) ->
+ freeVarsToLiveVars body_fvs `thenLne` \(body_lvs, _) ->
- returnLne (bind2, bind_fvs, bind_escs, bind_lvs,
- body2, body_fvs, body_escs, body_lvs)
+ returnLne (bind2, bind_fvs, bind_escs, bind_lvs, bind_cafs,
+ body2, body_fvs, body_escs, body_lvs)
+ )
- )) `thenLne` (\ (bind2, bind_fvs, bind_escs, bind_lvs,
- body2, body_fvs, body_escs, body_lvs) ->
+ ) `thenLne` (\ (bind2, bind_fvs, bind_escs, bind_lvs, bind_cafs,
+ body2, body_fvs, body_escs, body_lvs) ->
-- Compute the new let-expression
| otherwise = StgLet bind2 body2
free_in_whole_let
- = (bind_fvs `unionFVInfo` body_fvs) `minusFVBinders` binders
+ = binders `minusFVBinders` (bind_fvs `unionFVInfo` body_fvs)
live_in_whole_let
= bind_lvs `unionVarSet` (body_lvs `minusVarSet` set_of_binders)
let_escs = (real_bind_escs `unionVarSet` body_escs) `minusVarSet` set_of_binders
all_escs = bind_escs `unionVarSet` body_escs -- Still includes binders of
- -- this let(rec)
+ -- this let(rec)
no_binder_escapes = isEmptyVarSet (set_of_binders `intersectVarSet` all_escs)
NonRec binder rhs -> [binder]
Rec pairs -> map fst pairs
- mk_binding bind_lvs binder
- = (binder, LetrecBound False -- Not top level
- live_vars
+ mk_binding bind_lvs bind_cafs binder rhs
+ = (binder, LetBound NotTopLevelBound -- Not top level
+ live_vars (predictArity rhs)
)
where
live_vars = if let_no_escape then
- extendVarSet bind_lvs binder
+ (extendVarSet bind_lvs binder, bind_cafs)
else
- unitVarSet binder
+ (unitVarSet binder, emptyVarSet)
- vars_bind :: StgLiveVars
- -> FreeVarsInfo -- Free var info for body of binding
+ vars_bind :: FreeVarsInfo -- Free var info for body of binding
-> CoreBind
-> LneM (StgBinding,
- FreeVarsInfo, EscVarsSet, -- free vars; escapee vars
- [(Id, HowBound)])
- -- extension to environment
-
- vars_bind rec_bind_lvs rec_body_fvs (NonRec binder rhs)
- = coreToStgRhs rec_body_fvs NotTopLevel (binder,rhs)
- `thenLne` \ (rhs2, fvs, escs) ->
+ FreeVarsInfo,
+ EscVarsSet, -- free vars; escapee vars
+ StgLiveVars, -- vars live in binding
+ IdSet, -- CAFs live in binding
+ [(Id, HowBound)]) -- extension to environment
+
+
+ vars_bind body_fvs (NonRec binder rhs)
+ = coreToStgRhs body_fvs NotTopLevel (binder,rhs)
+ `thenLne` \ (rhs2, bind_fvs, escs) ->
+
+ freeVarsToLiveVars bind_fvs `thenLne` \ (bind_lvs, bind_cafs) ->
let
- env_ext_item@(binder', _) = mk_binding rec_bind_lvs binder
- in
- returnLne (StgNonRec binder' rhs2, fvs, escs, [env_ext_item])
-
- vars_bind rec_bind_lvs rec_body_fvs (Rec pairs)
- = let
- binders = map fst pairs
- env_ext = map (mk_binding rec_bind_lvs) binders
+ env_ext_item = mk_binding bind_lvs bind_cafs binder rhs
in
- extendVarEnvLne env_ext (
- fixLne (\ ~(_, rec_rhs_fvs, _, _) ->
- let
- rec_scope_fvs = unionFVInfo rec_body_fvs rec_rhs_fvs
- in
- mapAndUnzip3Lne (coreToStgRhs rec_scope_fvs NotTopLevel) pairs
+ returnLne (StgNonRec (SRTEntries bind_cafs) binder rhs2,
+ bind_fvs, escs, bind_lvs, bind_cafs, [env_ext_item])
+
+
+ vars_bind body_fvs (Rec pairs)
+ = fixLne (\ ~(_, rec_rhs_fvs, _, bind_lvs, bind_cafs, _) ->
+ let
+ rec_scope_fvs = unionFVInfo body_fvs rec_rhs_fvs
+ binders = map fst pairs
+ env_ext = [ mk_binding bind_lvs bind_cafs b rhs
+ | (b,rhs) <- pairs ]
+ in
+ extendVarEnvLne env_ext (
+ mapAndUnzip3Lne (coreToStgRhs rec_scope_fvs NotTopLevel) pairs
`thenLne` \ (rhss2, fvss, escss) ->
- let
- fvs = unionFVInfos fvss
- escs = unionVarSets escss
- in
- returnLne (StgRec (binders `zip` rhss2), fvs, escs, env_ext)
- ))
+ let
+ bind_fvs = unionFVInfos fvss
+ escs = unionVarSets escss
+ in
+ freeVarsToLiveVars (binders `minusFVBinders` bind_fvs)
+ `thenLne` \ (bind_lvs, bind_cafs) ->
+
+ returnLne (StgRec (SRTEntries bind_cafs) (binders `zip` rhss2),
+ bind_fvs, escs, bind_lvs, bind_cafs, env_ext)
+ )
+ )
is_join_var :: Id -> Bool
-- A hack (used only for compiler debuggging) to tell if
%************************************************************************
%* *
+\subsection{Arity prediction}
+%* *
+%************************************************************************
+
+To avoid yet another knot, we predict the arity of each function from
+its Core form, based on the number of visible top-level lambdas.
+It should be the same as the arity of the STG RHS!
+
+\begin{code}
+predictArity :: CoreExpr -> Int
+predictArity (Lam x e)
+ | isTyVar x = predictArity e
+ | otherwise = 1 + predictArity e
+predictArity (Note _ e)
+ -- Ignore coercions. Top level sccs are removed by the final
+ -- profiling pass, so we ignore those too.
+ = predictArity e
+predictArity _ = 0
+\end{code}
+
+
+%************************************************************************
+%* *
\subsection[LNE-monad]{A little monad for this let-no-escaping pass}
%* *
%************************************************************************
There's a lot of stuff to pass around, so we use this @LneM@ monad to
-help. All the stuff here is only passed {\em down}.
+help. All the stuff here is only passed *down*.
\begin{code}
-type LneM a = IdEnv HowBound
- -> StgLiveVars -- vars live in continuation
+type LneM a = IdEnv HowBound
+ -> (StgLiveVars, -- vars live in continuation
+ IdSet) -- cafs live in continuation
-> a
data HowBound
= ImportBound
| CaseBound
| LambdaBound
- | LetrecBound
- Bool -- True <=> bound at top level
- StgLiveVars -- Live vars... see notes below
+ | LetBound
+ TopLevelCafInfo
+ (StgLiveVars, IdSet) -- (Live vars, Live CAFs)... see notes below
+ Arity -- its arity (local Ids don't have arity info at this point)
-isLetrecBound (LetrecBound _ _) = True
-isLetrecBound other = False
+isLetBound (LetBound _ _ _) = True
+isLetBound other = False
\end{code}
-For a let(rec)-bound variable, x, we record what varibles 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 LetrecBound constructor; x itself *is* included.
+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.
+
+The set of live variables is guaranteed ot have no further let-no-escaped
+variables in it.
The std monad functions:
\begin{code}
-initLne :: LneM a -> a
-initLne m = m emptyVarEnv emptyVarSet
+initLne :: IdEnv HowBound -> LneM a -> a
+initLne env m = m env emptyLVS
+
+emptyLVS = (emptyVarSet,emptyVarSet)
{-# INLINE thenLne #-}
-{-# INLINE thenLne_ #-}
{-# INLINE returnLne #-}
returnLne :: a -> LneM a
returnLne e env lvs_cont = e
thenLne :: LneM a -> (a -> LneM b) -> LneM b
-thenLne m k env lvs_cont
- = case (m env lvs_cont) of
- m_result -> k m_result env lvs_cont
-
-thenLne_ :: LneM a -> LneM b -> LneM b
-thenLne_ m k env lvs_cont
- = case (m env lvs_cont) of
- _ -> k env lvs_cont
+thenLne m k env lvs_cont
+ = k (m env lvs_cont) env lvs_cont
mapLne :: (a -> LneM b) -> [a] -> LneM [b]
mapLne f [] = returnLne []
returnLne (r1:rs1, r2:rs2, r3:rs3)
fixLne :: (a -> LneM a) -> LneM a
-fixLne expr env lvs_cont = result
+fixLne expr env lvs_cont
+ = result
where
result = expr result env lvs_cont
--- ^^^^^^ ------ ^^^^^^
\end{code}
Functions specific to this monad:
+
\begin{code}
-getVarsLiveInCont :: LneM StgLiveVars
+getVarsLiveInCont :: LneM (StgLiveVars, IdSet)
getVarsLiveInCont env lvs_cont = lvs_cont
-setVarsLiveInCont :: StgLiveVars -> LneM a -> LneM a
+setVarsLiveInCont :: (StgLiveVars,IdSet) -> 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.
-lookupLiveVarsForSet :: FreeVarsInfo -> LneM StgLiveVars
-
-lookupLiveVarsForSet fvs env lvs_cont
- = returnLne (unionVarSets (map do_one (getFVs fvs)))
- env lvs_cont
+freeVarsToLiveVars :: FreeVarsInfo -> LneM (StgLiveVars, IdSet)
+freeVarsToLiveVars fvs env live_in_cont
+ = returnLne (lvs, cafs) env live_in_cont
where
+ (lvs_cont, cafs_cont) = live_in_cont -- not a strict pattern match!
+ (local, global) = partition isLocalId (allFreeIds fvs)
+
+ (lvs_from_fvs, caf_extras) = unzip (map do_one local)
+
+ lvs = unionVarSets lvs_from_fvs
+ `unionVarSet` lvs_cont
+
+ cafs = mkVarSet (filter is_caf_one global)
+ `unionVarSet` (unionVarSets caf_extras)
+ `unionVarSet` cafs_cont
+
do_one v
- = if isLocalId v then
- case (lookupVarEnv env v) of
- Just (LetrecBound _ lvs) -> extendVarSet lvs v
- Just _ -> unitVarSet v
- Nothing -> pprPanic "lookupVarEnv/do_one:" (ppr v)
- else
- emptyVarSet
+ = case (lookupVarEnv env v) of
+ Just (LetBound _ (lvs,cafs) _) -> (extendVarSet lvs v, cafs)
+ Just _ -> (unitVarSet v, emptyVarSet)
+ Nothing -> pprPanic "lookupLiveVarsForSet/do_one:" (ppr v)
+
+ is_caf_one v
+ = case lookupVarEnv env v of
+ Just (LetBound TopLevelHasCafs (lvs,_) _) ->
+ ASSERT( isEmptyVarSet lvs ) True
+ Just (LetBound _ _ _) -> False
+ _otherwise -> mayHaveCafRefs (idCafInfo v)
\end{code}
-
%************************************************************************
%* *
\subsection[Free-var info]{Free variable information}
%************************************************************************
\begin{code}
-type FreeVarsInfo = IdEnv (Id, Bool, StgBinderInfo)
- -- If f is mapped to NoStgBinderInfo, that means
- -- that f *is* mentioned (else it wouldn't be in the
- -- IdEnv at all), but only in a saturated applications.
- --
- -- All case/lambda-bound things are also mapped to
- -- NoStgBinderInfo, since we aren't interested in their
- -- occurence info.
- --
- -- The Bool is True <=> the Id is top level letrec bound
-
-type EscVarsSet = IdSet
+type FreeVarsInfo = VarEnv (Var, TopLevelCafInfo, 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.
+ --
+ -- All case/lambda-bound things are also mapped to
+ -- noBinderInfo, since we aren't interested in their
+ -- occurence info.
+ --
+ -- 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
-singletonFVInfo id ImportBound info = emptyVarEnv
-singletonFVInfo id (LetrecBound top_level _) info = unitVarEnv id (id, top_level, info)
-singletonFVInfo id other info = unitVarEnv id (id, False, info)
+singletonFVInfo id ImportBound info
+ | mayHaveCafRefs (idCafInfo id) = unitVarEnv id (id, TopLevelHasCafs, info)
+ | otherwise = emptyVarEnv
+singletonFVInfo id (LetBound top_level _ _) info
+ = unitVarEnv id (id, top_level, info)
+singletonFVInfo id other info
+ = unitVarEnv id (id, NotTopLevelBound, info)
+
+tyvarFVInfo :: TyVarSet -> FreeVarsInfo
+tyvarFVInfo tvs = foldVarSet add emptyFVInfo tvs
+ where
+ add tv fvs = extendVarEnv fvs tv (tv, NotTopLevelBound, noBinderInfo)
unionFVInfo :: FreeVarsInfo -> FreeVarsInfo -> FreeVarsInfo
unionFVInfo fv1 fv2 = plusVarEnv_C plusFVInfo fv1 fv2
unionFVInfos :: [FreeVarsInfo] -> FreeVarsInfo
unionFVInfos fvs = foldr unionFVInfo emptyFVInfo fvs
-minusFVBinders :: FreeVarsInfo -> [Id] -> FreeVarsInfo
-minusFVBinders fv ids = fv `delVarEnvList` ids
+minusFVBinders :: [Id] -> FreeVarsInfo -> FreeVarsInfo
+minusFVBinders vs fv = foldr minusFVBinder fv vs
+
+minusFVBinder :: Id -> FreeVarsInfo -> FreeVarsInfo
+minusFVBinder v fv | isId v && opt_RuntimeTypes
+ = (fv `delVarEnv` v) `unionFVInfo`
+ tyvarFVInfo (tyVarsOfType (idType v))
+ | otherwise = fv `delVarEnv` v
+ -- When removing a binder, remember to add its type variables
+ -- c.f. CoreFVs.delBinderFV
elementOfFVInfo :: Id -> FreeVarsInfo -> Bool
elementOfFVInfo id fvs = maybeToBool (lookupVarEnv fvs id)
lookupFVInfo :: FreeVarsInfo -> Id -> StgBinderInfo
-lookupFVInfo fvs id = case lookupVarEnv fvs id of
- Nothing -> NoStgBinderInfo
+-- Find how the given Id is used.
+-- Externally visible things may be used any old how
+lookupFVInfo fvs id
+ | isExternallyVisibleName (idName id) = noBinderInfo
+ | otherwise = case lookupVarEnv fvs id of
+ Nothing -> noBinderInfo
Just (_,_,info) -> info
-getFVs :: FreeVarsInfo -> [Id] -- Non-top-level things only
-getFVs fvs = [id | (id,False,_) <- rngVarEnv fvs]
+allFreeIds :: FreeVarsInfo -> [Id] -- Non-top-level things only
+allFreeIds fvs = [id | (id,_,_) <- rngVarEnv fvs, isId id]
+
+-- 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]
-getFVSet :: FreeVarsInfo -> IdSet
+getFVSet :: FreeVarsInfo -> VarSet
getFVSet fvs = mkVarSet (getFVs fvs)
plusFVInfo (id1,top1,info1) (id2,top2,info2)
\end{code}
Misc.
-
\begin{code}
-shouldBeVar (Note _ e) = shouldBeVar e
-shouldBeVar (Var v) = v
-shouldBeVar e = pprPanic "shouldBeVar" (ppr e)
+filterStgBinders :: [Var] -> [Var]
+filterStgBinders bndrs
+ | opt_RuntimeTypes = bndrs
+ | otherwise = filter isId bndrs
+\end{code}
+
--- ignore all notes except SCC
+\begin{code}
+ -- Ignore all notes except SCC
myCollectBinders expr
= go [] expr
where
go bs (Note _ e) = go bs e
go bs e = (reverse bs, e)
-myCollectArgs :: Expr b -> (Expr b, [Arg b])
+myCollectArgs :: CoreExpr -> (Id, [CoreArg])
+ -- We assume that we only have variables
+ -- in the function position by now
myCollectArgs expr
= go expr []
where
+ go (Var v) as = (v, as)
go (App f a) as = go f (a:as)
- go (Note (SCC _) e) as = panic "CoreToStg.myCollectArgs"
- go (Note n e) as = go e as
- go e as = (e, as)
+ go (Note (SCC _) e) as = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
+ go (Note n e) as = go e as
+ go _ as = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Figuring out CafInfo for an expression}
+%* *
+%************************************************************************
+
+hasCafRefs decides whether a top-level closure can point into the dynamic heap.
+We mark such things as `MayHaveCafRefs' because this information is
+used to decide whether a particular closure needs to be referenced
+in an SRT or not.
+
+There are two reasons for setting MayHaveCafRefs:
+ a) The RHS is a CAF: a top-level updatable thunk.
+ b) The RHS refers to something that MayHaveCafRefs
+
+Possible improvement: In an effort to keep the number of CAFs (and
+hence the size of the SRTs) down, we could also look at the expression and
+decide whether it requires a small bounded amount of heap, so we can ignore
+it as a CAF. In these cases however, we would need to use an additional
+CAF list to keep track of non-collectable CAFs.
+
+\begin{code}
+hasCafRefs :: IdEnv HowBound -> CoreExpr -> CafInfo
+-- Only called for the RHS of top-level lets
+hasCafRefss :: IdEnv HowBound -> [CoreExpr] -> CafInfo
+ -- predicate returns True for a given Id if we look at this Id when
+ -- calculating the result. Used to *avoid* looking at the CafInfo
+ -- field for an Id that is part of the current recursive group.
+
+hasCafRefs p expr
+ | isCAF expr || isFastTrue (cafRefs p expr) = MayHaveCafRefs
+ | otherwise = NoCafRefs
+
+ -- used for recursive groups. The whole group is set to
+ -- "MayHaveCafRefs" if at least one of the group is a CAF or
+ -- refers to any CAFs.
+hasCafRefss p exprs
+ | any isCAF exprs || isFastTrue (cafRefss p exprs) = MayHaveCafRefs
+ | otherwise = NoCafRefs
+
+-- cafRefs compiles to beautiful code :)
+
+cafRefs p (Var id)
+ | isLocalId id = fastBool False
+ | otherwise =
+ case lookupVarEnv p id of
+ Just (LetBound TopLevelHasCafs _ _) -> fastBool True
+ Just (LetBound _ _ _) -> fastBool False
+ Nothing -> fastBool (cgMayHaveCafRefs (idCgInfo id)) -- imported Ids
+
+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 (Note n e) = cafRefs p e
+cafRefs p (Type t) = fastBool False
+
+cafRefss p [] = fastBool False
+cafRefss p (e:es) = fastOr (cafRefs p e) (cafRefss p) es
+
+-- hack for lazy-or over FastBool.
+fastOr a f x = fastBool (isFastTrue a || isFastTrue (f x))
+
+isCAF :: CoreExpr -> Bool
+-- Only called for the RHS of top-level lets
+isCAF e = not (rhsIsNonUpd e)
+ {- ToDo: check type for onceness, i.e. non-updatable thunks? -}
+
+
+rhsIsNonUpd :: CoreExpr -> Bool
+ -- True => Value-lambda, constructor, PAP
+ -- This is a bit like CoreUtils.exprIsValue, with the following differences:
+ -- a) scc "foo" (\x -> ...) is updatable (so we catch the right SCC)
+ --
+ -- b) (C x xs), where C is a contructors is updatable if the application is
+ -- dynamic: see isDynConApp
+ --
+ -- c) don't look through unfolding of f in (f x). I'm suspicious of this one
+
+-- This function has to line up with what the update flag
+-- for the StgRhs gets set to in mkStgRhs (above)
+--
+-- When opt_RuntimeTypes is on, we keep type lambdas and treat
+-- them as making the RHS re-entrant (non-updatable).
+rhsIsNonUpd (Lam b e) = isRuntimeVar b || rhsIsNonUpd e
+rhsIsNonUpd (Note (SCC _) e) = False
+rhsIsNonUpd (Note _ e) = rhsIsNonUpd e
+rhsIsNonUpd other_expr
+ = go other_expr 0 []
+ where
+ go (Var f) n_args args = idAppIsNonUpd f n_args args
+
+ go (App f a) n_args args
+ | isTypeArg a = go f n_args args
+ | otherwise = go f (n_args + 1) (a:args)
+
+ go (Note (SCC _) f) n_args args = False
+ go (Note _ f) n_args args = go f n_args args
+
+ go other n_args args = False
+
+idAppIsNonUpd :: Id -> Int -> [CoreExpr] -> Bool
+idAppIsNonUpd id n_val_args args
+ | Just con <- isDataConId_maybe id = not (isCrossDllConApp con args)
+ | otherwise = n_val_args < idArity id
+
+isCrossDllConApp :: DataCon -> [CoreExpr] -> Bool
+isCrossDllConApp con args = isDllName (dataConName con) || any isCrossDllArg args
+-- Top-level constructor applications can usually be allocated
+-- statically, but they can't if
+-- a) the constructor, or any of the arguments, come from another DLL
+-- b) any of the arguments are LitLits
+-- (because we can't refer to static labels in other DLLs).
+-- If this happens we simply make the RHS into an updatable thunk,
+-- and 'exectute' it rather than allocating it statically.
+-- All this should match the decision in (see CoreToStg.coreToStgRhs)
+
+
+isCrossDllArg :: CoreExpr -> Bool
+-- True if somewhere in the expression there's a cross-DLL reference
+isCrossDllArg (Type _) = False
+isCrossDllArg (Var v) = isDllName (idName v)
+isCrossDllArg (Note _ e) = isCrossDllArg e
+isCrossDllArg (Lit lit) = isLitLitLit lit
+isCrossDllArg (App e1 e2) = isCrossDllArg e1 || isCrossDllArg e2 -- must be a type app
+isCrossDllArg (Lam v e) = isCrossDllArg e -- must be a type lam
\end{code}
projects / ghc-hetmet.git / blobdiff