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, Arity )
-import CmdLineOpts ( DynFlags, opt_KeepStgTypes )
+import CmdLineOpts ( DynFlags, opt_RuntimeTypes )
import FastTypes hiding ( fastOr )
import Outputable
coreTopBindToStg env body_fvs (NonRec id rhs)
= let
caf_info = hasCafRefs env rhs
- arity = exprArity rhs
- env' = extendVarEnv env id (LetBound how_bound emptyLVS arity)
+ 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)
caf_info = hasCafRefss env1{-NB: not env'-} rhss
env' = extendVarEnvList env
- [ (b, LetBound how_bound emptyLVS (exprArity rhs))
+ [ (b, LetBound how_bound emptyLVS (predictArity rhs))
| (b,rhs) <- pairs ]
how_bound | mayHaveCafRefs caf_info = TopLevelHasCafs
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)
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
_ -> 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
- | 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)
mk_binding bind_lvs bind_cafs binder rhs
= (binder, LetBound NotTopLevelBound -- Not top level
- live_vars (exprArity rhs)
+ live_vars (predictArity rhs)
)
where
live_vars = if let_no_escape then
freeVarsToLiveVars bind_fvs `thenLne` \ (bind_lvs, bind_cafs) ->
let
- env_ext_item@(binder', _) = mk_binding bind_lvs bind_cafs binder rhs
+ env_ext_item = mk_binding bind_lvs bind_cafs binder rhs
in
- returnLne (StgNonRec (SRTEntries bind_cafs) binder' rhs2,
+ returnLne (StgNonRec (SRTEntries bind_cafs) binder rhs2,
bind_fvs, escs, bind_lvs, bind_cafs, [env_ext_item])
%************************************************************************
%* *
+\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}
%* *
%************************************************************************
= 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)
Nothing -> pprPanic "lookupLiveVarsForSet/do_one:" (ppr v)
is_caf_one v
- = case lookupVarEnv env v of
+ = case lookupVarEnv env v of
Just (LetBound TopLevelHasCafs (lvs,_) _) ->
ASSERT( isEmptyVarSet lvs ) True
Just (LetBound _ _ _) -> False
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}
--
-- 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