-- * Properties of expressions
exprType, coreAltType, coreAltsType,
- exprIsDupable, exprIsTrivial, exprIsCheap, exprIsExpandable,
+ exprIsDupable, exprIsTrivial, exprIsBottom,
+ exprIsCheap, exprIsExpandable, exprIsCheap', CheapAppFun,
exprIsHNF, exprOkForSpeculation, exprIsBig, exprIsConLike,
rhsIsStatic, isCheapApp, isExpandableApp,
-- * Expression and bindings size
coreBindsSize, exprSize,
+ CoreStats(..), coreBindsStats,
-- * Hashing
hashExpr,
import VarEnv
import VarSet
import Name
-#if mingw32_TARGET_OS
-import Packages
-#endif
import Literal
import DataCon
import PrimOp
import Unique
import Outputable
import TysPrim
-import PrelNames( absentErrorIdKey )
import FastString
import Maybes
import Util
exprIsTrivial _ = False
\end{code}
+exprIsBottom is a very cheap and cheerful function; it may return
+False for bottoming expressions, but it never costs much to ask.
+See also CoreArity.exprBotStrictness_maybe, but that's a bit more
+expensive.
+
+\begin{code}
+exprIsBottom :: CoreExpr -> Bool
+exprIsBottom e
+ = go 0 e
+ where
+ go n (Var v) = isBottomingId v && n >= idArity v
+ go n (App e a) | isTypeArg a = go n e
+ | otherwise = go (n+1) e
+ go n (Note _ e) = go n e
+ go n (Cast e _) = go n e
+ go n (Let _ e) = go n e
+ go _ _ = False
+\end{code}
+
%************************************************************************
%* *
\begin{code}
exprIsDupable :: CoreExpr -> Bool
-exprIsDupable (Type _) = True
-exprIsDupable (Var _) = True
-exprIsDupable (Lit lit) = litIsDupable lit
-exprIsDupable (Note _ e) = exprIsDupable e
-exprIsDupable (Cast e _) = exprIsDupable e
-exprIsDupable expr
- = go expr 0
+exprIsDupable e
+ = isJust (go dupAppSize e)
where
- go (Var _) _ = True
- go (App f a) n_args = n_args < dupAppSize
- && exprIsDupable a
- && go f (n_args+1)
- go _ _ = False
+ go :: Int -> CoreExpr -> Maybe Int
+ go n (Type {}) = Just n
+ go n (Var {}) = decrement n
+ go n (Note _ e) = go n e
+ go n (Cast e _) = go n e
+ go n (App f a) | Just n' <- go n a = go n' f
+ go n (Lit lit) | litIsDupable lit = decrement n
+ go _ _ = Nothing
+
+ decrement :: Int -> Maybe Int
+ decrement 0 = Nothing
+ decrement n = Just (n-1)
dupAppSize :: Int
-dupAppSize = 4 -- Size of application we are prepared to duplicate
+dupAppSize = 8 -- Size of term we are prepared to duplicate
+ -- This is *just* big enough to make test MethSharing
+ -- inline enough join points. Really it should be
+ -- smaller, and could be if we fixed Trac #4960.
\end{code}
%************************************************************************
exprIsExpandable :: CoreExpr -> Bool
exprIsExpandable = exprIsCheap' isExpandableApp -- See Note [CONLIKE pragma] in BasicTypes
-
-exprIsCheap' :: (Id -> Int -> Bool) -> CoreExpr -> Bool
+type CheapAppFun = Id -> Int -> Bool
+exprIsCheap' :: CheapAppFun -> CoreExpr -> Bool
exprIsCheap' _ (Lit _) = True
exprIsCheap' _ (Type _) = True
exprIsCheap' _ (Var _) = True
= go other_expr []
where
-- Accumulate value arguments, then decide
+ go (Cast e _) val_args = go e val_args
go (App f a) val_args | isRuntimeArg a = go f (a:val_args)
| otherwise = go f val_args
go (Var _) [] = True -- Just a type application of a variable
-- (f t1 t2 t3) counts as WHNF
go (Var f) args
- = case idDetails f of
+ = case idDetails f of
RecSelId {} -> go_sel args
ClassOpId {} -> go_sel args
PrimOpId op -> go_primop op args
-- BUT: Take care with (sel d x)! The (sel d) might be cheap, but
-- there's no guarantee that (sel d x) will be too. Hence (n_val_args == 1)
-isCheapApp :: Id -> Int -> Bool
+isCheapApp :: CheapAppFun
isCheapApp fn n_val_args
= isDataConWorkId fn
|| n_val_args < idArity fn
-isExpandableApp :: Id -> Int -> Bool
+isExpandableApp :: CheapAppFun
isExpandableApp fn n_val_args
= isConLikeId fn
|| n_val_args < idArity fn
--
-- * Safe /not/ to evaluate even if normal order would do so
--
+-- It is usually called on arguments of unlifted type, but not always
+-- In particular, Simplify.rebuildCase calls it on lifted types
+-- when a 'case' is a plain 'seq'. See the example in
+-- Note [exprOkForSpeculation: case expressions] below
+--
-- Precisely, it returns @True@ iff:
--
-- * The expression guarantees to terminate,
exprOkForSpeculation :: CoreExpr -> Bool
exprOkForSpeculation (Lit _) = True
exprOkForSpeculation (Type _) = True
- -- Tick boxes are *not* suitable for speculation
-exprOkForSpeculation (Var v) = isUnLiftedType (idType v)
- && not (isTickBoxOp v)
+
+exprOkForSpeculation (Var v)
+ | isTickBoxOp v = False -- Tick boxes are *not* suitable for speculation
+ | otherwise = isUnLiftedType (idType v) -- c.f. the Var case of exprIsHNF
+ || isDataConWorkId v -- Nullary constructors
+ || idArity v > 0 -- Functions
+ || isEvaldUnfolding (idUnfolding v) -- Let-bound values
+
exprOkForSpeculation (Note _ e) = exprOkForSpeculation e
exprOkForSpeculation (Cast e _) = exprOkForSpeculation e
exprOkForSpeculation other_expr
= case collectArgs other_expr of
- (Var f, args) | f `hasKey` absentErrorIdKey -- Note [Absent error Id]
- -> all exprOkForSpeculation args -- in WwLib
- | otherwise
- -> spec_ok (idDetails f) args
+ (Var f, args) -> spec_ok (idDetails f) args
_ -> False
where
-- Often there is a literal divisor, and this
-- can get rid of a thunk in an inner looop
+ | DataToTagOp <- op -- See Note [dataToTag speculation]
+ = True
+
| otherwise
= primOpOkForSpeculation op &&
all exprOkForSpeculation args
-- A bit conservative: we don't really need
-- to care about lazy arguments, but this is easy
- spec_ok (DFunId new_type) _ = not new_type
+ spec_ok (DFunId _ new_type) _ = not new_type
-- DFuns terminate, unless the dict is implemented with a newtype
-- in which case they may not
Note [exprOkForSpeculation: case expressions]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
It's always sound for exprOkForSpeculation to return False, and we
don't want it to take too long, so it bales out on complicated-looking
terms. Notably lets, which can be stacked very deeply; and in any
so any lets will have been floated away.
However, we keep going on case-expressions. An example like this one
-showed up in DPH code:
+showed up in DPH code (Trac #3717):
foo :: Int -> Int
foo 0 = 0
foo n = (if n < 5 then 1 else 2) `seq` foo (n-1)
\ (ww :: GHC.Prim.Int#) ->
case ww of ds {
__DEFAULT -> case (case <# ds 5 of _ {
- GHC.Bool.False -> lvl1;
- GHC.Bool.True -> lvl})
+ GHC.Types.False -> lvl1;
+ GHC.Types.True -> lvl})
of _ { __DEFAULT ->
T.$wfoo (GHC.Prim.-# ds_XkE 1) };
0 -> 0
The inner case is redundant, and should be nuked.
+Note [dataToTag speculation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Is this OK?
+ f x = let v::Int# = dataToTag# x
+ in ...
+We say "yes", even though 'x' may not be evaluated. Reasons
+
+ * dataToTag#'s strictness means that its argument often will be
+ evaluated, but FloatOut makes that temporarily untrue
+ case x of y -> let v = dataToTag# y in ...
+ -->
+ case x of y -> let v = dataToTag# x in ...
+ Note that we look at 'x' instead of 'y' (this is to improve
+ floating in FloatOut). So Lint complains.
+
+ Moreover, it really *might* improve floating to let the
+ v-binding float out
+
+ * CorePrep makes sure dataToTag#'s argument is evaluated, just
+ before code gen. Until then, it's not guaranteed
+
%************************************************************************
%* *
exprSize :: CoreExpr -> Int
-- ^ A measure of the size of the expressions, strictly greater than 0
-- It also forces the expression pretty drastically as a side effect
+-- Counts *leaves*, not internal nodes. Types and coercions are not counted.
exprSize (Var v) = v `seq` 1
exprSize (Lit lit) = lit `seq` 1
exprSize (App f a) = exprSize f + exprSize a
altSize (c,bs,e) = c `seq` varsSize bs + exprSize e
\end{code}
+\begin{code}
+data CoreStats = CS { cs_tm, cs_ty, cs_co :: Int }
+
+plusCS :: CoreStats -> CoreStats -> CoreStats
+plusCS (CS { cs_tm = p1, cs_ty = q1, cs_co = r1 })
+ (CS { cs_tm = p2, cs_ty = q2, cs_co = r2 })
+ = CS { cs_tm = p1+p2, cs_ty = q1+q2, cs_co = r1+r2 }
+
+zeroCS, oneTM :: CoreStats
+zeroCS = CS { cs_tm = 0, cs_ty = 0, cs_co = 0 }
+oneTM = zeroCS { cs_tm = 1 }
+
+sumCS :: (a -> CoreStats) -> [a] -> CoreStats
+sumCS f = foldr (plusCS . f) zeroCS
+
+coreBindsStats :: [CoreBind] -> CoreStats
+coreBindsStats = sumCS bindStats
+
+bindStats :: CoreBind -> CoreStats
+bindStats (NonRec v r) = bindingStats v r
+bindStats (Rec prs) = sumCS (\(v,r) -> bindingStats v r) prs
+
+bindingStats :: Var -> CoreExpr -> CoreStats
+bindingStats v r = bndrStats v `plusCS` exprStats r
+
+bndrStats :: Var -> CoreStats
+bndrStats v = oneTM `plusCS` tyStats (varType v)
+
+exprStats :: CoreExpr -> CoreStats
+exprStats (Var {}) = oneTM
+exprStats (Lit {}) = oneTM
+exprStats (App f (Type t))= tyCoStats (exprType f) t
+exprStats (App f a) = exprStats f `plusCS` exprStats a
+exprStats (Lam b e) = bndrStats b `plusCS` exprStats e
+exprStats (Let b e) = bindStats b `plusCS` exprStats e
+exprStats (Case e b _ as) = exprStats e `plusCS` bndrStats b `plusCS` sumCS altStats as
+exprStats (Cast e co) = coStats co `plusCS` exprStats e
+exprStats (Note _ e) = exprStats e
+exprStats (Type ty) = zeroCS { cs_ty = typeSize ty }
+ -- Ugh (might be a co)
+
+altStats :: CoreAlt -> CoreStats
+altStats (_, bs, r) = sumCS bndrStats bs `plusCS` exprStats r
+
+tyCoStats :: Type -> Type -> CoreStats
+tyCoStats fun_ty arg
+ = case splitForAllTy_maybe fun_ty of
+ Just (tv,_) | isCoVar tv -> coStats arg
+ _ -> tyStats arg
+
+tyStats :: Type -> CoreStats
+tyStats ty = zeroCS { cs_ty = typeSize ty }
+
+coStats :: Coercion -> CoreStats
+coStats co = zeroCS { cs_co = typeSize co }
+\end{code}
%************************************************************************
%* *
projects / ghc-hetmet.git / blobdiff