Modifications to the way we calculate CafInfo during tidying (again).
The previous hack of setting the CafInfo on all non-top-level bindings
to NoCafRefs was a hack, and it came back to bite us: when CorePrep
floats out a let to the top level it doesn't create a new binding, and
the existing let binder happens to say NoCafRefs which is unsafe. It
was caught by an ASSERT in the CoreToStg when compiling the libraries
without -O - compiling without -O tends to result in more
opportunities for CorePrep to float things to the top level.
Now, we calculate CafInfo on the pre-tidied expressions, using the
mapping from Ids to Ids that is being built up during tidying. This
avoids one loop, but will be slightly slower due to the extra lookups.
However, it means we don't need to set the CafInfo on non-top-level
binders to NoCafRefs.
import PprCore ( pprIdRules )
import Id ( Id, mkUserLocal, idInfo, setIdInfo, idUnique,
idType, idCoreRules )
-import IdInfo ( setArityInfo, noCafIdInfo,
+import IdInfo ( setArityInfo, vanillaIdInfo,
newStrictnessInfo, setAllStrictnessInfo,
newDemandInfo, setNewDemandInfo )
import Type ( tidyType, tidyTyVarBndr )
--
-- Similarly arity info for eta expansion in CorePrep
--
- -- CafInfo is NoCafRefs, because this is not a top-level Id.
- --
final_id = new_id `setIdInfo` new_info
idinfo = idInfo id
- new_info = noCafIdInfo -- NB. no CAF refs!
+ new_info = vanillaIdInfo
`setArityInfo` exprArity rhs
`setAllStrictnessInfo` newStrictnessInfo idinfo
`setNewDemandInfo` newDemandInfo idinfo
-- The SrcLoc isn't important now,
-- though we could extract it from the Id
--
- -- All nested Ids now have the same IdInfo, namely noCafIdInfo,
+ -- All nested Ids now have the same IdInfo, namely vanillaIdInfo,
-- which should save some space.
-- But note that tidyLetBndr puts some of it back.
ty' = tidyType env (idType id)
id' = mkUserLocal occ' (idUnique id) ty' noSrcLoc
- `setIdInfo` noCafIdInfo
+ `setIdInfo` vanillaIdInfo
var_env' = extendVarEnv var_env id id'
in
((tidy_env', var_env'), id')
exprIsBottom, exprIsDupable, exprIsTrivial, exprIsCheap,
exprIsValue,exprOkForSpeculation, exprIsBig,
exprIsConApp_maybe, exprIsAtom,
- idAppIsBottom, idAppIsCheap,
-
+ idAppIsBottom, idAppIsCheap, rhsIsNonUpd,
-- Arity and eta expansion
manifestArity, exprArity,
-- Equality
cheapEqExpr, eqExpr, applyTypeToArgs, applyTypeToArg,
- -- CAF info
- hasCafRefs, rhsIsNonUpd,
-
-- Cross-DLL references
isCrossDllConApp,
) where
import Id ( Id, idType, globalIdDetails, idNewStrictness,
mkWildId, idArity, idName, idUnfolding, idInfo,
isOneShotLambda, isDataConWorkId_maybe, mkSysLocal,
- isDataConWorkId, isBottomingId, idCafInfo
+ isDataConWorkId, isBottomingId
)
-import IdInfo ( GlobalIdDetails(..), megaSeqIdInfo,
- CafInfo(..), mayHaveCafRefs )
+import IdInfo ( GlobalIdDetails(..), megaSeqIdInfo )
import NewDemand ( appIsBottom )
import Type ( Type, mkFunTy, mkForAllTy, splitFunTy_maybe,
splitFunTy,
import TysPrim ( alphaTy ) -- Debugging only
import Util ( equalLength, lengthAtLeast )
import TysPrim ( statePrimTyCon )
-import FastTypes hiding ( fastOr )
\end{code}
%************************************************************************
%* *
-\subsection{Figuring out CafInfo for an expression}
+\subsection{Determining non-updatable right-hand-sides}
%* *
%************************************************************************
-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 :: (Var -> Bool) -> Arity -> CoreExpr -> CafInfo
-hasCafRefs p arity expr
- | is_caf || mentions_cafs = MayHaveCafRefs
- | otherwise = NoCafRefs
- where
- mentions_cafs = isFastTrue (cafRefs p expr)
- is_caf = not (arity > 0 || rhsIsNonUpd expr)
- -- NB. we pass in the arity of the expression, which is expected
- -- to be calculated by exprArity. This is because exprArity
- -- knows how much eta expansion is going to be done by
- -- CorePrep later on, and we don't want to duplicate that
- -- knowledge in rhsIsNonUpd below.
-
-cafRefs p (Var id)
- | isId id && p id = fastBool (mayHaveCafRefs (idCafInfo id))
- | otherwise = fastBool False
-
-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))
-
-
rhsIsNonUpd :: CoreExpr -> Bool
-- True => Value-lambda, saturated constructor
-- This is a bit like CoreUtils.exprIsValue, with the following differences:
import CoreTidy ( tidyExpr, tidyVarOcc, tidyIdRules )
import PprCore ( pprIdRules )
import CoreLint ( showPass, endPass )
-import CoreUtils ( exprArity, hasCafRefs )
+import CoreUtils ( exprArity, rhsIsNonUpd )
import VarEnv
import VarSet
import Var ( Id, Var )
import Id ( idType, idInfo, idName, idCoreRules,
isExportedId, mkVanillaGlobal, isLocalId,
- isImplicitId, idArity, setIdInfo
+ isImplicitId, idArity, setIdInfo, idCafInfo
)
import IdInfo {- loads of stuff -}
import NewDemand ( isBottomingSig, topSig )
-import BasicTypes ( isNeverActive )
+import BasicTypes ( Arity, isNeverActive )
import Name ( getOccName, nameOccName, mkInternalName,
localiseName, isExternalName, nameSrcLoc
)
import Util ( mapAccumL )
import Maybe ( isJust )
import Outputable
+import FastTypes hiding ( fastOr )
\end{code}
-> TopTidyEnv -> CoreBind
-> (TopTidyEnv, CoreBind)
-tidyTopBind mod ext_ids top_tidy_env (NonRec bndr rhs)
+tidyTopBind mod ext_ids top_tidy_env@(_,_,subst1) (NonRec bndr rhs)
= ((orig,occ,subst) , NonRec bndr' rhs')
where
((orig,occ,subst), bndr')
rec_tidy_env rhs rhs' top_tidy_env bndr
rec_tidy_env = (occ,subst)
rhs' = tidyExpr rec_tidy_env rhs
- caf_info = hasCafRefs (const True) (idArity bndr') rhs'
+ caf_info = hasCafRefs subst1 (idArity bndr') rhs'
-tidyTopBind mod ext_ids top_tidy_env (Rec prs)
+tidyTopBind mod ext_ids top_tidy_env@(_,_,subst1) (Rec prs)
= (final_env, Rec prs')
where
(final_env@(_,occ,subst), prs') = mapAccumL do_one top_tidy_env prs
-- the CafInfo for a recursive group says whether *any* rhs in
-- the group may refer indirectly to a CAF (because then, they all do).
- pred v = v `notElem` map fst prs'
caf_info
- | or [ mayHaveCafRefs (hasCafRefs pred (idArity bndr) rhs)
- | (bndr,rhs) <- prs' ] = MayHaveCafRefs
+ | or [ mayHaveCafRefs (hasCafRefs subst1 (idArity bndr) rhs)
+ | (bndr,rhs) <- prs ] = MayHaveCafRefs
| otherwise = NoCafRefs
tidyTopBinder :: Module -> IdEnv Bool -> CafInfo
tidyWorker tidy_env other
= NoWorker
\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 :: VarEnv Var -> Arity -> CoreExpr -> CafInfo
+hasCafRefs p arity expr
+ | is_caf || mentions_cafs = MayHaveCafRefs
+ | otherwise = NoCafRefs
+ where
+ mentions_cafs = isFastTrue (cafRefs p expr)
+ is_caf = not (arity > 0 || rhsIsNonUpd expr)
+ -- NB. we pass in the arity of the expression, which is expected
+ -- to be calculated by exprArity. This is because exprArity
+ -- knows how much eta expansion is going to be done by
+ -- CorePrep later on, and we don't want to duplicate that
+ -- knowledge in rhsIsNonUpd below.
+
+cafRefs p (Var id)
+ -- imported Ids first:
+ | not (isLocalId id) = fastBool (mayHaveCafRefs (idCafInfo id))
+ -- now Ids local to this module:
+ | otherwise =
+ case lookupVarEnv p id of
+ Just id' -> fastBool (mayHaveCafRefs (idCafInfo id'))
+ Nothing -> fastBool False
+
+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))
+\end{code}
in
ASSERT2(and [manifestArity rhs == stgRhsArity stg_rhs | (rhs,stg_rhs) <- rhss `zip` stg_rhss], ppr binders)
ASSERT2(consistentCafInfo (head binders) bind, ppr binders)
--- WARN(not (consistent caf_info bind), ppr binders <+> ppr cafs <+> ppCafInfo caf_info)
(env', fvs' `unionFVInfo` body_fvs, bind)
#ifdef DEBUG
-- floated out a binding, in which case it will be approximate.
consistentCafInfo id bind
| occNameFS (nameOccName (idName id)) == FSLIT("sat")
- = id_marked_caffy || not binding_is_caffy
+ = safe
| otherwise
- = id_marked_caffy == binding_is_caffy
+ = WARN (not exact, ppr id) safe
where
+ safe = id_marked_caffy || not binding_is_caffy
+ exact = id_marked_caffy == binding_is_caffy
id_marked_caffy = mayHaveCafRefs (idCafInfo id)
binding_is_caffy = stgBindHasCafRefs bind
#endif
projects / ghc-hetmet.git / commitdiff