import TyCon ( isAlgTyCon )
import Literal
import Id
-import Var ( Var, globalIdDetails )
+import Var ( Var, globalIdDetails, varType )
import IdInfo
import DataCon
import CostCentre ( noCCS )
import VarEnv
import DataCon ( dataConWrapId )
import IdInfo ( OccInfo(..) )
-import TysPrim ( foreignObjPrimTyCon )
import Maybes ( maybeToBool )
import Name ( getOccName, isExternallyVisibleName, isDllName )
import OccName ( occNameUserString )
-import BasicTypes ( TopLevelFlag(..), isNotTopLevel )
-import CmdLineOpts ( DynFlags, opt_KeepStgTypes )
+import BasicTypes ( TopLevelFlag(..), isNotTopLevel, Arity )
+import CmdLineOpts ( DynFlags, opt_RuntimeTypes )
import FastTypes hiding ( fastOr )
import Outputable
coreToStg :: DynFlags -> [CoreBind] -> IO [StgBinding]
coreToStg dflags pgm
= return pgm'
- where (env', fvs, pgm') = coreTopBindsToStg emptyVarEnv pgm
+ where (_, _, pgm') = coreTopBindsToStg emptyVarEnv pgm
coreExprToStg :: CoreExpr -> StgExpr
coreExprToStg expr
coreTopBindsToStg env [] = (env, emptyFVInfo, [])
coreTopBindsToStg env (b:bs)
- = (env2, fvs1, b':bs')
+ = (env2, fvs2, b':bs')
where
-- env accumulates down the list of binds, fvs accumulates upwards
(env1, fvs2, b' ) = coreTopBindToStg env fvs1 b
= let
caf_info = hasCafRefs env rhs
- env' = extendVarEnv env id (LetBound how_bound emptyVarSet)
+ env' = extendVarEnv env id (LetBound how_bound emptyLVS (predictArity rhs))
how_bound | mayHaveCafRefs caf_info = TopLevelHasCafs
| otherwise = TopLevelNoCafs
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)
-- to calculate caf_info, we initially map all the binders to
-- TopLevelNoCafs.
env1 = extendVarEnvList env
- [ (b, LetBound TopLevelNoCafs emptyVarSet) | b <- binders ]
+ [ (b, LetBound TopLevelNoCafs emptyLVS (error "no arity"))
+ | b <- binders ]
caf_info = hasCafRefss env1{-NB: not env'-} rhss
env' = extendVarEnvList env
- [ (b, LetBound how_bound emptyVarSet) | b <- binders ]
+ [ (b, LetBound how_bound emptyLVS (predictArity rhs))
+ | (b,rhs) <- pairs ]
how_bound | mayHaveCafRefs caf_info = TopLevelHasCafs
| otherwise = TopLevelNoCafs
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)
where
binder_info = lookupFVInfo scope_fv_info binder
-bogus_rhs = StgRhsClosure noCCS noBinderInfo [] ReEntrant [] bogus_expr
-bogus_expr = (StgLit (MachInt 1))
-
mkStgRhs :: TopLevelFlag -> FreeVarsInfo -> StgBinderInfo
-> StgExpr -> StgRhs
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}
mkStgAlgAlts ty alts deflt
= case alts of
lookupVarLne f `thenLne` \ how_bound ->
let
- n_args = length args
+ n_val_args = valArgCount args
not_letrec_bound = not (isLetBound how_bound)
- fun_fvs = singletonFVInfo f how_bound fun_occ
+ 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
-- let f = \ab -> e in f
-- No point in having correct arity info for f!
-- Hence the hasArity stuff below.
- f_arity_info = idArityInfo f
- f_arity = arityLowerBound f_arity_info -- Zero if no info
+ f_arity = case how_bound of
+ LetBound _ _ arity -> arity
+ _ -> 0
fun_occ
- | not_letrec_bound = noBinderInfo -- Uninteresting variable
- | f_arity > 0 && f_arity <= n_args = stgSatOcc -- Saturated or over-saturated function call
- | otherwise = stgUnsatOcc -- Unsaturated function or thunk
+ | 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
- | hasArity f_arity_info &&
- f_arity == n_args = emptyVarSet -- A function *or thunk* with an exactly
+ | 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)
-- continuation, but it does no harm to just union the
-- two regardless.
+ res_ty = exprType (mkApps (Var f) args)
app = case globalIdDetails f of
- DataConId dc -> StgConApp dc args'
- PrimOpId op -> StgPrimApp op args' (exprType (mkApps (Var f) args))
+ 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
coreToStgArgs (Type ty : args) -- Type argument
= coreToStgArgs args `thenLne` \ (args', fvs) ->
- if opt_KeepStgTypes then
+ if opt_RuntimeTypes then
returnLne (StgTypeArg ty : args', fvs `unionFVInfo` tyvarFVInfo (tyVarsOfType ty))
else
returnLne (args', fvs)
-- 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 (emptyVarSet,emptyVarSet))
+ else emptyLVS)
(vars_bind rec_body_fvs bind)
- `thenLne` \ (bind2, bind_fvs, bind_escs, bind_lvs, env_ext) ->
+ `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) ->
freeVarsToLiveVars body_fvs `thenLne` \(body_lvs, _) ->
- returnLne (bind2, bind_fvs, bind_escs, bind_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,
+ ) `thenLne` (\ (bind2, bind_fvs, bind_escs, bind_lvs, bind_cafs,
body2, body_fvs, body_escs, body_lvs) ->
NonRec binder rhs -> [binder]
Rec pairs -> map fst pairs
- mk_binding bind_lvs binder
+ mk_binding bind_lvs bind_cafs binder rhs
= (binder, LetBound NotTopLevelBound -- Not top level
- live_vars
+ 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 :: FreeVarsInfo -- Free var info for body of binding
-> CoreBind
FreeVarsInfo,
EscVarsSet, -- free vars; escapee vars
StgLiveVars, -- vars live in binding
+ IdSet, -- CAFs live in binding
[(Id, HowBound)]) -- extension to environment
freeVarsToLiveVars bind_fvs `thenLne` \ (bind_lvs, bind_cafs) ->
let
- env_ext_item@(binder', _) = mk_binding bind_lvs binder
+ env_ext_item = mk_binding bind_lvs bind_cafs binder rhs
in
- returnLne (StgNonRec (SRTEntries bind_cafs) binder' rhs2,
- bind_fvs, escs, bind_lvs, [env_ext_item])
+ 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, _) ->
+ = fixLne (\ ~(_, rec_rhs_fvs, _, bind_lvs, bind_cafs, _) ->
let
rec_scope_fvs = unionFVInfo body_fvs rec_rhs_fvs
binders = map fst pairs
- env_ext = map (mk_binding bind_lvs) binders
+ env_ext = [ mk_binding bind_lvs bind_cafs b rhs
+ | (b,rhs) <- pairs ]
in
extendVarEnvLne env_ext (
mapAndUnzip3Lne (coreToStgRhs rec_scope_fvs NotTopLevel) pairs
in
freeVarsToLiveVars (binders `minusFVBinders` bind_fvs)
`thenLne` \ (bind_lvs, bind_cafs) ->
+
returnLne (StgRec (SRTEntries bind_cafs) (binders `zip` rhss2),
- bind_fvs, escs, bind_lvs, env_ext)
+ bind_fvs, escs, bind_lvs, bind_cafs, env_ext)
)
)
%************************************************************************
%* *
+\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}
%* *
%************************************************************************
| LambdaBound
| LetBound
TopLevelCafInfo
- StgLiveVars -- Live vars... see notes below
+ (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
+isLetBound (LetBound _ _ _) = True
+isLetBound other = False
\end{code}
For a let(rec)-bound variable, x, we record StgLiveVars, the set of
The std monad functions:
\begin{code}
initLne :: IdEnv HowBound -> LneM a -> a
-initLne env m = m env (emptyVarSet,emptyVarSet)
+initLne env m = m env emptyLVS
+
+emptyLVS = (emptyVarSet,emptyVarSet)
{-# INLINE thenLne #-}
{-# INLINE returnLne #-}
freeVarsToLiveVars :: FreeVarsInfo -> LneM (StgLiveVars, IdSet)
freeVarsToLiveVars fvs env live_in_cont
- = returnLne (lvs `unionVarSet` lvs_cont,
- mkVarSet cafs `unionVarSet` cafs_cont)
- 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 (allFVs fvs)
+ (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 = filter is_caf_one global
- lvs = unionVarSets (map do_one local)
+ 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 (LetBound _ lvs) -> extendVarSet lvs v
- Just _ -> unitVarSet v
+ = case (lookupVarEnv env v) of
+ Just (LetBound _ (lvs,cafs) _) -> (extendVarSet lvs v, cafs)
+ Just _ -> (unitVarSet v, emptyVarSet)
Nothing -> pprPanic "lookupLiveVarsForSet/do_one:" (ppr v)
- else
- emptyVarSet
is_caf_one v
- = case lookupVarEnv env v of
- Just (LetBound TopLevelHasCafs lvs) ->
+ = case lookupVarEnv env v of
+ Just (LetBound TopLevelHasCafs (lvs,_) _) ->
ASSERT( isEmptyVarSet lvs ) True
- Just (LetBound _ _) -> False
+ Just (LetBound _ _ _) -> False
_otherwise -> mayHaveCafRefs (idCafInfo v)
\end{code}
singletonFVInfo id ImportBound info
| mayHaveCafRefs (idCafInfo id) = unitVarEnv id (id, TopLevelHasCafs, info)
| otherwise = emptyVarEnv
-singletonFVInfo id (LetBound top_level _) info
+singletonFVInfo id (LetBound top_level _ _) info
= unitVarEnv id (id, top_level, info)
singletonFVInfo id other info
= unitVarEnv id (id, NotTopLevelBound, info)
minusFVBinders vs fv = foldr minusFVBinder fv vs
minusFVBinder :: Id -> FreeVarsInfo -> FreeVarsInfo
-minusFVBinder v fv | isId v && opt_KeepStgTypes
+minusFVBinder v fv | isId v && opt_RuntimeTypes
= (fv `delVarEnv` v) `unionFVInfo`
tyvarFVInfo (tyVarsOfType (idType v))
| otherwise = fv `delVarEnv` v
Nothing -> noBinderInfo
Just (_,_,info) -> info
-allFVs :: FreeVarsInfo -> [Id] -- Non-top-level things only
-allFVs fvs = [id | (id,_,_) <- rngVarEnv fvs]
+allFreeIds :: FreeVarsInfo -> [Id] -- Non-top-level things only
+allFreeIds fvs = [id | (id,_,_) <- rngVarEnv fvs, isId id]
-getFVs :: FreeVarsInfo -> [Id] -- Non-top-level things only
+-- 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)
\begin{code}
filterStgBinders :: [Var] -> [Var]
filterStgBinders bndrs
- | opt_KeepStgTypes = bndrs
+ | opt_RuntimeTypes = bndrs
| otherwise = filter isId bndrs
\end{code}
| isLocalId id = fastBool False
| otherwise =
case lookupVarEnv p id of
- Just (LetBound TopLevelHasCafs _) -> fastBool True
- Just (LetBound _ _) -> fastBool False
+ Just (LetBound TopLevelHasCafs _ _) -> fastBool True
+ Just (LetBound _ _ _) -> fastBool False
Nothing -> fastBool (cgMayHaveCafRefs (idCgInfo id)) -- imported Ids
cafRefs p (Lit l) = fastBool False
--
-- c) don't look through unfolding of f in (f x). I'm suspicious of this one
-rhsIsNonUpd (Lam b e) = isId b || rhsIsNonUpd e
+-- 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
idAppIsNonUpd :: Id -> Int -> [CoreExpr] -> Bool
idAppIsNonUpd id n_val_args args
- | Just con <- isDataConId_maybe id = not (isDynConApp con args)
+ | Just con <- isDataConId_maybe id = not (isCrossDllConApp con args)
| otherwise = n_val_args < idArity id
-isDynConApp :: DataCon -> [CoreExpr] -> Bool
-isDynConApp con args = isDllName (dataConName con) || any isDynArg args
+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
-- All this should match the decision in (see CoreToStg.coreToStgRhs)
-isDynArg :: CoreExpr -> Bool
-isDynArg (Var v) = isDllName (idName v)
-isDynArg (Note _ e) = isDynArg e
-isDynArg (Lit lit) = isLitLitLit lit
-isDynArg (App e _) = isDynArg e -- must be a type app
-isDynArg (Lam _ e) = isDynArg e -- must be a type lam
+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