\begin{code}
-- | Arit and eta expansion
module CoreArity (
- manifestArity, exprArity,
+ manifestArity, exprArity, exprBotStrictness_maybe,
exprEtaExpandArity, etaExpand
) where
import CoreSyn
import CoreFVs
import CoreUtils
-import NewDemand
-import TyCon ( isRecursiveTyCon )
-import qualified CoreSubst
-import CoreSubst ( Subst, substBndr, substBndrs, substExpr
- , mkEmptySubst, isEmptySubst )
+import CoreSubst
+import Demand
import Var
import VarEnv
import Id
import Type
+import TyCon ( isRecursiveTyCon )
import TcType ( isDictLikeTy )
import Coercion
import BasicTypes
-- ^ An approximate, fast, version of 'exprEtaExpandArity'
exprArity e = go e
where
- go (Var v) = idArity v
- go (Lam x e) | isId x = go e + 1
- | otherwise = go e
- go (Note _ e) = go e
- go (Cast e co) = trim_arity (go e) 0 (snd (coercionKind co))
- go (App e (Type _)) = go e
- go (App f a) | exprIsCheap a = (go f - 1) `max` 0
- -- NB: exprIsCheap a!
- -- f (fac x) does not have arity 2,
- -- even if f has arity 3!
- -- NB: `max 0`! (\x y -> f x) has arity 2, even if f is
- -- unknown, hence arity 0
+ go (Var v) = idArity v
+ go (Lam x e) | isId x = go e + 1
+ | otherwise = go e
+ go (Note _ e) = go e
+ go (Cast e co) = go e `min` typeArity (snd (coercionKind co))
+ -- Note [exprArity invariant]
+ go (App e (Type _)) = go e
+ go (App f a) | exprIsTrivial a = (go f - 1) `max` 0
+ -- See Note [exprArity for applications]
go _ = 0
-
- -- Note [exprArity invariant]
- trim_arity n a ty
- | n==a = a
- | Just (_, ty') <- splitForAllTy_maybe ty = trim_arity n a ty'
- | Just (_, ty') <- splitFunTy_maybe ty = trim_arity n (a+1) ty'
- | Just (ty',_) <- splitNewTypeRepCo_maybe ty = trim_arity n a ty'
- | otherwise = a
\end{code}
+Note [exprArity for applications]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we come to an application we check that the arg is trivial.
+ eg f (fac x) does not have arity 2,
+ even if f has arity 3!
+
+* We require that is trivial rather merely cheap. Suppose f has arity 2.
+ Then f (Just y)
+ has arity 0, because if we gave it arity 1 and then inlined f we'd get
+ let v = Just y in \w. <f-body>
+ which has arity 0. And we try to maintain the invariant that we don't
+ have arity decreases.
+
+* The `max 0` is important! (\x y -> f x) has arity 2, even if f is
+ unknown, hence arity 0
+
+
%************************************************************************
%* *
Eta expansion
= applyStateHack e (arityType dicts_cheap e)
where
dicts_cheap = dopt Opt_DictsCheap dflags
+
+exprBotStrictness_maybe :: CoreExpr -> Maybe (Arity, StrictSig)
+-- A cheap and cheerful function that identifies bottoming functions
+-- and gives them a suitable strictness signatures. It's used during
+-- float-out
+exprBotStrictness_maybe e
+ = case arityType False e of
+ AT _ ATop -> Nothing
+ AT a ABot -> Just (a, mkStrictSig (mkTopDmdType (replicate a topDmd) BotRes))
\end{code}
Note [Definition of arity]
is as efficient as
C[ e ]
-
It's all a bit more subtle than it looks:
Note [Arity of case expressions]
"problem", because being scrupulous would lose an important transformation for
many programs.
-
1. Note [One-shot lambdas]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider one-shot lambdas
do so; it improves some programs significantly, and increasing convergence
isn't a bad thing. Hence the ABot/ATop in ArityType.
-
4. Note [Newtype arity]
~~~~~~~~~~~~~~~~~~~~~~~~
Non-recursive newtypes are transparent, and should not get in the way.
And since negate has arity 2, you might try to eta expand. But you can't
decopose Int to a function type. Hence the final case in eta_expand.
-Note [The state-transformer hack]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Suppose we have
- f = e
-where e has arity n. Then, if we know from the context that f has
-a usage type like
- t1 -> ... -> tn -1-> t(n+1) -1-> ... -1-> tm -> ...
-then we can expand the arity to m. This usage type says that
-any application (x e1 .. en) will be applied to uniquely to (m-n) more args
-Consider f = \x. let y = <expensive>
- in case x of
- True -> foo
- 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.
-
-Then we expect that if f is applied to one arg, it'll be applied to two
-(that's the hack -- we don't really know, and sometimes it's false)
-See also Id.isOneShotBndr.
-
\begin{code}
applyStateHack :: CoreExpr -> ArityType -> Arity
applyStateHack e (AT orig_arity is_bot)
go :: Type -> Arity -> Arity
go ty arity -- This case analysis should match that in eta_expand
| Just (_, ty') <- splitForAllTy_maybe ty = go ty' arity
+ | Just (arg,res) <- splitFunTy_maybe ty
+ , arity > 0 || isStateHackType arg = 1 + go res (arity-1)
+-- See Note [trimCast]
| Just (tc,tys) <- splitTyConApp_maybe ty
, Just (ty', _) <- instNewTyCon_maybe tc tys
, not (isRecursiveTyCon tc) = go ty' arity
-- Important to look through non-recursive newtypes, so that, eg
-- (f x) where f has arity 2, f :: Int -> IO ()
-- Here we want to get arity 1 for the result!
+-------
- | Just (arg,res) <- splitFunTy_maybe ty
- , arity > 0 || isStateHackType arg = 1 + go res (arity-1)
{-
= if arity > 0 then 1 + go res (arity-1)
else if isStateHackType arg then
1 + go res (arity-1)
else WARN( arity > 0, ppr arity ) 0
-}
- | otherwise = WARN( arity > 0, ppr arity ) 0
+ | otherwise = WARN( arity > 0, ppr arity <+> ppr ty) 0
\end{code}
+Note [The state-transformer hack]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have
+ f = e
+where e has arity n. Then, if we know from the context that f has
+a usage type like
+ t1 -> ... -> tn -1-> t(n+1) -1-> ... -1-> tm -> ...
+then we can expand the arity to m. This usage type says that
+any application (x e1 .. en) will be applied to uniquely to (m-n) more args
+Consider f = \x. let y = <expensive>
+ in case x of
+ True -> foo
+ 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.
+
+Then we expect that if f is applied to one arg, it'll be applied to two
+(that's the hack -- we don't really know, and sometimes it's false)
+See also Id.isOneShotBndr.
+
Note [State hack and bottoming functions]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
It's a terrible idea to use the state hack on a bottoming function.
andArityType (AT a1 ATop) (AT _ ABot) = AT a1 ATop
andArityType (AT a1 ABot) (AT a2 ABot) = AT (a1 `max` a2) ABot
+---------------------------
+trimCast :: Coercion -> ArityType -> ArityType
+-- Trim the arity to be no more than allowed by the
+-- arrows in ty2, where co :: ty1~ty2
+trimCast _ at = at
+
+{- Omitting for now Note [trimCast]
+trimCast co at@(AT ar _)
+ | ar > co_arity = AT co_arity ATop
+ | otherwise = at
+ where
+ (_, ty2) = coercionKind co
+ co_arity = typeArity ty2
+-}
+\end{code}
+
+Note [trimCast]
+~~~~~~~~~~~~~~~
+When you try putting trimCast back in, comment out the snippets
+flagged by the other references to Note [trimCast]
+
+\begin{code}
+---------------------------
trimArity :: Bool -> ArityType -> ArityType
-- We have something like (let x = E in b), where b has the given
-- arity type. Then
---------------------------
arityType :: Bool -> CoreExpr -> ArityType
arityType _ (Var v)
- | Just strict_sig <- idNewStrictness_maybe v
+ | Just strict_sig <- idStrictness_maybe v
, (ds, res) <- splitStrictSig strict_sig
, isBotRes res
= AT (length ds) ABot -- Function diverges
-- See Note [Dictionary-like types] in TcType.lhs for why we use
-- isDictLikeTy here rather than isDictTy
-arityType dicts_cheap (Note _ e) = arityType dicts_cheap e
-arityType dicts_cheap (Cast e _) = arityType dicts_cheap e
-arityType _ _ = vanillaArityType
+arityType dicts_cheap (Note _ e) = arityType dicts_cheap e
+arityType dicts_cheap (Cast e co) = trimCast co (arityType dicts_cheap e)
+arityType _ _ = vanillaArityType
\end{code}
a subsequent clean-up phase of the Simplifier to de-crapify the result,
means you can't really use it in CorePrep, which is painful.
+Note [Eta expansion and SCCs]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Note that SCCs are not treated specially by etaExpand. If we have
+ etaExpand 2 (\x -> scc "foo" e)
+ = (\xy -> (scc "foo" e) y)
+So the costs of evaluating 'e' (not 'e y') are attributed to "foo"
+
\begin{code}
-- | @etaExpand n us e ty@ returns an expression with
-- the same meaning as @e@, but with arity @n@.
etaExpand :: Arity -- ^ Result should have this number of value args
-> CoreExpr -- ^ Expression to expand
-> CoreExpr
--- Note that SCCs are not treated specially. If we have
--- etaExpand 2 (\x -> scc "foo" e)
--- = (\xy -> (scc "foo" e) y)
--- So the costs of evaluating 'e' (not 'e y') are attributed to "foo"
-
-- etaExpand deals with for-alls. For example:
-- etaExpand 1 E
-- where E :: forall a. a -> a
-- so perhaps the extra code isn't worth it
etaExpand n orig_expr
- | manifestArity orig_expr >= n = orig_expr -- The no-op case
- | otherwise
= go n orig_expr
where
- -- Strip off existing lambdas
+ -- Strip off existing lambdas and casts
-- Note [Eta expansion and SCCs]
go 0 expr = expr
go n (Lam v body) | isTyVar v = Lam v (go n body)
| otherwise = Lam v (go (n-1) body)
- go n (Note InlineMe expr) = Note InlineMe (go n expr)
go n (Cast expr co) = Cast (go n expr) co
go n expr = -- pprTrace "ee" (vcat [ppr orig_expr, ppr expr, ppr etas]) $
etaInfoAbs etas (etaInfoApp subst' expr etas)
-- Outgoing InScopeSet includes the EtaInfo vars
-- and the original free vars
-mkEtaWW n in_scope ty
- = go n empty_subst ty []
+mkEtaWW orig_n in_scope orig_ty
+ = go orig_n empty_subst orig_ty []
where
empty_subst = mkTvSubst in_scope emptyTvSubstEnv
-- Avoid free vars of the original expression
= go (n-1) subst' res_ty (EtaVar eta_id' : eis)
+-- See Note [trimCast]
| Just(ty',co) <- splitNewTypeRepCo_maybe ty
= -- Given this:
-- newtype T = MkT ([T] -> Int)
-- eta_expand 1 e T
-- We want to get
-- coerce T (\x::[T] -> (coerce ([T]->Int) e) x)
- go n subst ty' (EtaCo (substTy subst co) : eis)
+ go n subst ty' (EtaCo (Type.substTy subst co) : eis)
+-------
| otherwise -- We have an expression of arity > 0,
- = (getTvInScope subst, reverse eis) -- but its type isn't a function.
+ = WARN( True, ppr orig_n <+> ppr orig_ty )
+ (getTvInScope subst, reverse eis) -- but its type isn't a function.
-- This *can* legitmately happen:
-- e.g. coerce Int (\x. x) Essentially the programmer is
-- playing fast and loose with types (Happy does this a lot).
--------------
--- Avoiding unnecessary substitution
+-- Avoiding unnecessary substitution; use short-cutting versions
subst_expr :: Subst -> CoreExpr -> CoreExpr
-subst_expr s e | isEmptySubst s = e
- | otherwise = substExpr s e
+subst_expr = substExprSC (text "CoreArity:substExpr")
subst_bind :: Subst -> CoreBind -> (Subst, CoreBind)
-subst_bind subst (NonRec b r)
- = (subst', NonRec b' (subst_expr subst r))
- where
- (subst', b') = substBndr subst b
-subst_bind subst (Rec prs)
- = (subst', Rec (bs1 `zip` map (subst_expr subst') rhss))
- where
- (bs, rhss) = unzip prs
- (subst', bs1) = substBndrs subst bs
+subst_bind = substBindSC
--------------
freshEtaId n subst ty
= (subst', eta_id')
where
- ty' = substTy subst ty
+ ty' = Type.substTy subst ty
eta_id' = uniqAway (getTvInScope subst) $
mkSysLocal (fsLit "eta") (mkBuiltinUnique n) ty'
- subst' = extendTvInScope subst [eta_id']
+ subst' = extendTvInScope subst eta_id'
\end{code}
projects / ghc-hetmet.git / blobdiff