import VarSet ( unionVarSet )
import VarEnv
import Name ( hashName )
-import Packages ( HomeModules )
#if mingw32_TARGET_OS
import Packages ( isDllName )
#endif
import Id ( Id, idType, globalIdDetails, idNewStrictness,
mkWildId, idArity, idName, idUnfolding, idInfo,
isOneShotBndr, isStateHackType, isDataConWorkId_maybe, mkSysLocal,
- isDataConWorkId, isBottomingId
+ isDataConWorkId, isBottomingId, isDictId
)
import IdInfo ( GlobalIdDetails(..), megaSeqIdInfo )
import NewDemand ( appIsBottom )
import TysWiredIn ( boolTy, trueDataCon, falseDataCon )
import CostCentre ( CostCentre )
import BasicTypes ( Arity )
+import PackageConfig ( PackageId )
import Unique ( Unique )
import Outputable
+import DynFlags ( DynFlags, DynFlag(Opt_DictsCheap), dopt )
import TysPrim ( alphaTy ) -- Debugging only
import Util ( equalLength, lengthAtLeast, foldl2 )
\end{code}
\begin{code}
exprIsCheap :: CoreExpr -> Bool
-exprIsCheap (Lit lit) = True
-exprIsCheap (Type _) = True
-exprIsCheap (Var _) = True
-exprIsCheap (Note InlineMe e) = True
-exprIsCheap (Note _ e) = exprIsCheap e
-exprIsCheap (Lam x e) = isRuntimeVar x || exprIsCheap e
-exprIsCheap (Case e _ _ alts) = exprIsCheap e &&
- and [exprIsCheap rhs | (_,_,rhs) <- alts]
+exprIsCheap (Lit lit) = True
+exprIsCheap (Type _) = True
+exprIsCheap (Var _) = True
+exprIsCheap (Note InlineMe e) = True
+exprIsCheap (Note _ e) = exprIsCheap e
+exprIsCheap (Lam x e) = isRuntimeVar x || exprIsCheap e
+exprIsCheap (Case e _ _ alts) = exprIsCheap e &&
+ and [exprIsCheap rhs | (_,_,rhs) <- alts]
-- Experimentally, treat (case x of ...) as cheap
-- (and case __coerce x etc.)
-- This improves arities of overloaded functions where
exprIsCheap (Let (NonRec x _) e)
| isUnLiftedType (idType x) = exprIsCheap e
| otherwise = False
- -- strict lets always have cheap right hand sides, and
- -- do no allocation.
+ -- strict lets always have cheap right hand sides,
+ -- and do no allocation.
-exprIsCheap other_expr
- = go other_expr 0 True
+exprIsCheap other_expr -- Applications and variables
+ = go other_expr []
where
- go (Var f) n_args args_cheap
- = (idAppIsCheap f n_args && args_cheap)
- -- A constructor, cheap primop, or partial application
-
- || idAppIsBottom f n_args
+ -- Accumulate value arguments, then decide
+ go (App f a) val_args | isRuntimeArg a = go f (a:val_args)
+ | otherwise = go f val_args
+
+ go (Var f) [] = True -- Just a type application of a variable
+ -- (f t1 t2 t3) counts as WHNF
+ go (Var f) args
+ = case globalIdDetails f of
+ RecordSelId {} -> go_sel args
+ ClassOpId _ -> go_sel args
+ PrimOpId op -> go_primop op args
+
+ DataConWorkId _ -> go_pap args
+ other | length args < idArity f -> go_pap args
+
+ other -> isBottomingId f
-- Application of a function which
-- always gives bottom; we treat this as cheap
-- because it certainly doesn't need to be shared!
- go (App f a) n_args args_cheap
- | not (isRuntimeArg a) = go f n_args args_cheap
- | otherwise = go f (n_args + 1) (exprIsCheap a && args_cheap)
-
- go other n_args args_cheap = False
-
-idAppIsCheap :: Id -> Int -> Bool
-idAppIsCheap id n_val_args
- | n_val_args == 0 = True -- Just a type application of
- -- a variable (f t1 t2 t3)
- -- counts as WHNF
- | otherwise
- = case globalIdDetails id of
- DataConWorkId _ -> True
- RecordSelId {} -> n_val_args == 1 -- I'm experimenting with making record selection
- ClassOpId _ -> n_val_args == 1 -- look cheap, so we will substitute it inside a
- -- lambda. Particularly for dictionary field selection.
- -- 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)
-
- PrimOpId op -> primOpIsCheap op -- In principle we should worry about primops
- -- that return a type variable, since the result
- -- might be applied to something, but I'm not going
- -- to bother to check the number of args
- other -> n_val_args < idArity id
+ go other args = False
+
+ --------------
+ go_pap args = all exprIsTrivial args
+ -- For constructor applications and primops, check that all
+ -- the args are trivial. We don't want to treat as cheap, say,
+ -- (1:2:3:4:5:[])
+ -- We'll put up with one constructor application, but not dozens
+
+ --------------
+ go_primop op args = primOpIsCheap op && all exprIsCheap args
+ -- In principle we should worry about primops
+ -- that return a type variable, since the result
+ -- might be applied to something, but I'm not going
+ -- to bother to check the number of args
+
+ --------------
+ go_sel [arg] = exprIsCheap arg -- I'm experimenting with making record selection
+ go_sel other = False -- look cheap, so we will substitute it inside a
+ -- lambda. Particularly for dictionary field selection.
+ -- 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)
\end{code}
exprOkForSpeculation returns True of an expression that it is
without raising an exception,
without causing a side effect (e.g. writing a mutable variable)
+NB: if exprIsHNF e, then exprOkForSpecuation e
+
E.G.
let x = case y# +# 1# of { r# -> I# r# }
in E
-- There is at least one value argument
app_is_value (Var fun) args
- | isDataConWorkId fun -- Constructor apps are values
+ | isDataConWorkId fun -- Constructor apps are values
|| idArity fun > valArgCount args -- Under-applied function
= check_args (idType fun) args
app_is_value (App f a) as = app_is_value f (a:as)
%************************************************************************
\begin{code}
-exprEtaExpandArity :: CoreExpr -> Arity
+exprEtaExpandArity :: DynFlags -> CoreExpr -> Arity
{- The Arity returned is the number of value args the
thing can be applied to without doing much work
-}
-exprEtaExpandArity e = arityDepth (arityType e)
+exprEtaExpandArity dflags e = arityDepth (arityType dflags e)
-- A limited sort of function type
data ArityType = AFun Bool ArityType -- True <=> one-shot
andArityType (AFun t1 at1) (AFun t2 at2) = AFun (t1 && t2) (andArityType at1 at2)
andArityType at1 at2 = andArityType at2 at1
-arityType :: CoreExpr -> ArityType
+arityType :: DynFlags -> CoreExpr -> ArityType
-- (go1 e) = [b1,..,bn]
-- means expression can be rewritten \x_b1 -> ... \x_bn -> body
-- where bi is True <=> the lambda is one-shot
-arityType (Note n e) = arityType e
+arityType dflags (Note n e) = arityType dflags e
-- Not needed any more: etaExpand is cleverer
--- | ok_note n = arityType e
+-- | ok_note n = arityType dflags e
-- | otherwise = ATop
-arityType (Var v)
+arityType dflags (Var v)
= mk (idArity v) (arg_tys (idType v))
where
mk :: Arity -> [Type] -> ArityType
-- False -> \(s:RealWorld) -> e
-- where foo has arity 1. Then we want the state hack to
-- apply to foo too, so we can eta expand the case.
- mk 0 tys | isBottomingId v = ABot
- | otherwise = ATop
+ mk 0 tys | isBottomingId v = ABot
+ | (ty:tys) <- tys, isStateHackType ty = AFun True ATop
+ | otherwise = ATop
mk n (ty:tys) = AFun (isStateHackType ty) (mk (n-1) tys)
mk n [] = AFun False (mk (n-1) [])
| otherwise = []
-- Lambdas; increase arity
-arityType (Lam x e) | isId x = AFun (isOneShotBndr x) (arityType e)
- | otherwise = arityType e
+arityType dflags (Lam x e)
+ | isId x = AFun (isOneShotBndr x) (arityType dflags e)
+ | otherwise = arityType dflags e
-- Applications; decrease arity
-arityType (App f (Type _)) = arityType f
-arityType (App f a) = case arityType f of
- AFun one_shot xs | exprIsCheap a -> xs
- other -> ATop
+arityType dflags (App f (Type _)) = arityType dflags f
+arityType dflags (App f a) = case arityType dflags f of
+ AFun one_shot xs | exprIsCheap a -> xs
+ other -> ATop
-- Case/Let; keep arity if either the expression is cheap
-- or it's a 1-shot lambda
-- ===>
-- f x y = case x of { (a,b) -> e }
-- The difference is observable using 'seq'
-arityType (Case scrut _ _ alts) = case foldr1 andArityType [arityType rhs | (_,_,rhs) <- alts] of
- xs@(AFun one_shot _) | one_shot -> xs
- xs | exprIsCheap scrut -> xs
- | otherwise -> ATop
-
-arityType (Let b e) = case arityType e of
- xs@(AFun one_shot _) | one_shot -> xs
- xs | all exprIsCheap (rhssOfBind b) -> xs
- | otherwise -> ATop
-
-arityType other = ATop
+arityType dflags (Case scrut _ _ alts)
+ = case foldr1 andArityType [arityType dflags rhs | (_,_,rhs) <- alts] of
+ xs | exprIsCheap scrut -> xs
+ xs@(AFun one_shot _) | one_shot -> AFun True ATop
+ other -> ATop
+
+arityType dflags (Let b e)
+ = case arityType dflags e of
+ xs | cheap_bind b -> xs
+ xs@(AFun one_shot _) | one_shot -> AFun True ATop
+ other -> ATop
+ where
+ cheap_bind (NonRec b e) = is_cheap (b,e)
+ cheap_bind (Rec prs) = all is_cheap prs
+ is_cheap (b,e) = (dopt Opt_DictsCheap dflags && isDictId b)
+ || exprIsCheap e
+ -- If the experimental -fdicts-cheap flag is on, we eta-expand through
+ -- dictionary bindings. This improves arities. Thereby, it also
+ -- means that full laziness is less prone to floating out the
+ -- application of a function to its dictionary arguments, which
+ -- can thereby lose opportunities for fusion. Example:
+ -- foo :: Ord a => a -> ...
+ -- foo = /\a \(d:Ord a). let d' = ...d... in \(x:a). ....
+ -- -- So foo has arity 1
+ --
+ -- f = \x. foo dInt $ bar x
+ --
+ -- The (foo DInt) is floated out, and makes ineffective a RULE
+ -- foo (bar x) = ...
+ --
+ -- One could go further and make exprIsCheap reply True to any
+ -- dictionary-typed expression, but that's more work.
+
+arityType dflags other = ATop
{- NOT NEEDED ANY MORE: etaExpand is cleverer
ok_note InlineMe = False
and 'exectute' it rather than allocating it statically.
\begin{code}
-rhsIsStatic :: HomeModules -> CoreExpr -> Bool
+rhsIsStatic :: PackageId -> CoreExpr -> Bool
-- This function is called only on *top-level* right-hand sides
-- Returns True if the RHS can be allocated statically, with
-- no thunks involved at all.
-- When opt_RuntimeTypes is on, we keep type lambdas and treat
-- them as making the RHS re-entrant (non-updatable).
-rhsIsStatic hmods rhs = is_static False rhs
+rhsIsStatic this_pkg rhs = is_static False rhs
where
is_static :: Bool -- True <=> in a constructor argument; must be atomic
-> CoreExpr -> Bool
where
go (Var f) n_val_args
#if mingw32_TARGET_OS
- | not (isDllName hmods (idName f))
+ | not (isDllName this_pkg (idName f))
#endif
= saturated_data_con f n_val_args
|| (in_arg && n_val_args == 0)
projects / ghc-hetmet.git / blobdiff