import VarSet ( unionVarSet )
import VarEnv
import Name ( hashName )
-import Packages ( HomeModules )
#if mingw32_TARGET_OS
import Packages ( isDllName )
#endif
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 )
\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
-- 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
soon,
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)
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