Commit a7dbafe9 authored by Simon Peyton Jones's avatar Simon Peyton Jones

No join-point from an INLINE function with wrong arity

The main payload of this patch is NOT to make a join-point
from a function with an INLINE pragma and the wrong arity;
see Note [Join points and INLINE pragmas] in CoreOpt.
This is what caused Trac #13413.

But we must do the exact same thing in simpleOptExpr,
which drove me to the following refactoring:

* Move simpleOptExpr and simpleOptPgm from CoreSubst to a new
  module CoreOpt along with a few others (exprIsConApp_maybe,
  pushCoArg, etc)

  This eliminates a module loop altogether (delete
  CoreArity.hs-boot), and stops CoreSubst getting too huge.

* Rename Simplify.matchOrConvertToJoinPoint
     to joinPointBinding_maybe
  Move it to the new CoreOpt
  Use it in simpleOptExpr as well as in Simplify

* Define CoreArity.joinRhsArity and use it
parent 567bc6bd
......@@ -10,9 +10,10 @@
-- | Arity and eta expansion
module CoreArity (
manifestArity, exprArity, typeArity, exprBotStrictness_maybe,
manifestArity, joinRhsArity, exprArity, typeArity,
exprEtaExpandArity, findRhsArity, CheapFun, etaExpand,
etaExpandToJoinPoint, etaExpandToJoinPointRule
etaExpandToJoinPoint, etaExpandToJoinPointRule,
exprBotStrictness_maybe
) where
#include "HsVersions.h"
......@@ -77,6 +78,14 @@ manifestArity (Tick t e) | not (tickishIsCode t) = manifestArity e
manifestArity (Cast e _) = manifestArity e
manifestArity _ = 0
joinRhsArity :: CoreExpr -> JoinArity
-- Join points are supposed to have manifestly-visible
-- lambdas at the top: no ticks, no casts, nothing
-- Moreover, type lambdas count in JoinArity
joinRhsArity (Lam _ e) = 1 + joinRhsArity e
joinRhsArity _ = 0
---------------
exprArity :: CoreExpr -> Arity
-- ^ An approximate, fast, version of 'exprEtaExpandArity'
......
module CoreArity where
import BasicTypes
import CoreSyn
etaExpandToJoinPoint :: JoinArity -> CoreExpr -> ([CoreBndr], CoreExpr)
{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-}
{-# LANGUAGE CPP #-}
module CoreOpt (
-- ** Simple expression optimiser
simpleOptPgm, simpleOptExpr, simpleOptExprWith,
-- ** Join points
joinPointBinding_maybe, joinPointBindings_maybe,
-- ** Predicates on expressions
exprIsConApp_maybe, exprIsLiteral_maybe, exprIsLambda_maybe,
-- ** Coercions and casts
pushCoArg, pushCoValArg, pushCoTyArg, collectBindersPushingCo
) where
#include "HsVersions.h"
import CoreArity( joinRhsArity, etaExpandToJoinPoint )
import CoreSyn
import CoreSubst
import CoreUtils
import CoreFVs
import PprCore ( pprCoreBindings, pprRules )
import OccurAnal( occurAnalyseExpr, occurAnalysePgm )
import Literal ( Literal(MachStr) )
import Id
import Var ( varType )
import VarSet
import VarEnv
import DataCon
import OptCoercion ( optCoercion )
import Type hiding ( substTy, extendTvSubst, extendCvSubst, extendTvSubstList
, isInScope, substTyVarBndr, cloneTyVarBndr )
import Coercion hiding ( substCo, substCoVarBndr )
import TyCon ( tyConArity )
import TysWiredIn
import PrelNames
import BasicTypes
import Module ( Module )
import ErrUtils
import DynFlags
import Outputable
import Pair
import Util
import Maybes ( orElse )
import FastString
import Data.List
import qualified Data.ByteString as BS
{-
************************************************************************
* *
The Simple Optimiser
* *
************************************************************************
Note [The simple optimiser]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
The simple optimiser is a lightweight, pure (non-monadic) function
that rapidly does a lot of simple optimisations, including
- inlining things that occur just once,
or whose RHS turns out to be trivial
- beta reduction
- case of known constructor
- dead code elimination
It does NOT do any call-site inlining; it only inlines a function if
it can do so unconditionally, dropping the binding. It thereby
guarantees to leave no un-reduced beta-redexes.
It is careful to follow the guidance of "Secrets of the GHC inliner",
and in particular the pre-inline-unconditionally and
post-inline-unconditionally story, to do effective beta reduction on
functions called precisely once, without repeatedly optimising the same
expression. In fact, the simple optimiser is a good example of this
little dance in action; the full Simplifier is a lot more complicated.
-}
simpleOptExpr :: CoreExpr -> CoreExpr
-- See Note [The simple optimiser]
-- Do simple optimisation on an expression
-- The optimisation is very straightforward: just
-- inline non-recursive bindings that are used only once,
-- or where the RHS is trivial
--
-- We also inline bindings that bind a Eq# box: see
-- See Note [Getting the map/coerce RULE to work].
--
-- Also we convert functions to join points where possible (as
-- the occurrence analyser does most of the work anyway).
--
-- The result is NOT guaranteed occurrence-analysed, because
-- in (let x = y in ....) we substitute for x; so y's occ-info
-- may change radically
simpleOptExpr expr
= -- pprTrace "simpleOptExpr" (ppr init_subst $$ ppr expr)
simpleOptExprWith init_subst expr
where
init_subst = mkEmptySubst (mkInScopeSet (exprFreeVars expr))
-- It's potentially important to make a proper in-scope set
-- Consider let x = ..y.. in \y. ...x...
-- Then we should remember to clone y before substituting
-- for x. It's very unlikely to occur, because we probably
-- won't *be* substituting for x if it occurs inside a
-- lambda.
--
-- It's a bit painful to call exprFreeVars, because it makes
-- three passes instead of two (occ-anal, and go)
simpleOptExprWith :: Subst -> InExpr -> OutExpr
-- See Note [The simple optimiser]
simpleOptExprWith subst expr
= simple_opt_expr init_env (occurAnalyseExpr expr)
where
init_env = SOE { soe_inl = emptyVarEnv, soe_subst = subst }
----------------------
simpleOptPgm :: DynFlags -> Module
-> CoreProgram -> [CoreRule] -> [CoreVect]
-> IO (CoreProgram, [CoreRule], [CoreVect])
-- See Note [The simple optimiser]
simpleOptPgm dflags this_mod binds rules vects
= do { dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
(pprCoreBindings occ_anald_binds $$ pprRules rules );
; return (reverse binds', rules', vects') }
where
occ_anald_binds = occurAnalysePgm this_mod (\_ -> False) {- No rules active -}
rules vects emptyVarSet binds
(final_env, binds') = foldl do_one (emptyEnv, []) occ_anald_binds
final_subst = soe_subst final_env
rules' = substRulesForImportedIds final_subst rules
vects' = substVects final_subst vects
-- We never unconditionally inline into rules,
-- hence pasing just a substitution
do_one (env, binds') bind
= case simple_opt_bind env bind of
(env', Nothing) -> (env', binds')
(env', Just bind') -> (env', bind':binds')
-- In these functions the substitution maps InVar -> OutExpr
----------------------
type SimpleClo = (SimpleOptEnv, InExpr)
data SimpleOptEnv
= SOE { soe_inl :: IdEnv SimpleClo
-- Deals with preInlineUnconditionally; things
-- that occur exactly once and are inlined
-- without having first been simplified
, soe_subst :: Subst
-- Deals with cloning; includes the InScopeSet
}
instance Outputable SimpleOptEnv where
ppr (SOE { soe_inl = inl, soe_subst = subst })
= text "SOE {" <+> vcat [ text "soe_inl =" <+> ppr inl
, text "soe_subst =" <+> ppr subst ]
<+> text "}"
emptyEnv :: SimpleOptEnv
emptyEnv = SOE { soe_inl = emptyVarEnv
, soe_subst = emptySubst }
soeZapSubst :: SimpleOptEnv -> SimpleOptEnv
soeZapSubst (SOE { soe_subst = subst })
= SOE { soe_inl = emptyVarEnv, soe_subst = zapSubstEnv subst }
soeSetInScope :: SimpleOptEnv -> SimpleOptEnv -> SimpleOptEnv
-- Take in-scope set from env1, and the rest from env2
soeSetInScope (SOE { soe_subst = subst1 })
env2@(SOE { soe_subst = subst2 })
= env2 { soe_subst = setInScope subst2 (substInScope subst1) }
---------------
simple_opt_clo :: SimpleOptEnv -> SimpleClo -> OutExpr
simple_opt_clo env (e_env, e)
= simple_opt_expr (soeSetInScope env e_env) e
simple_opt_expr :: SimpleOptEnv -> InExpr -> OutExpr
simple_opt_expr env expr
= go expr
where
subst = soe_subst env
in_scope = substInScope subst
in_scope_env = (in_scope, simpleUnfoldingFun)
go (Var v)
| Just clo <- lookupVarEnv (soe_inl env) v
= simple_opt_clo env clo
| otherwise
= lookupIdSubst (text "simpleOptExpr") (soe_subst env) v
go (App e1 e2) = simple_app env e1 [(env,e2)]
go (Type ty) = Type (substTy subst ty)
go (Coercion co) = Coercion (optCoercion (getTCvSubst subst) co)
go (Lit lit) = Lit lit
go (Tick tickish e) = mkTick (substTickish subst tickish) (go e)
go (Cast e co) | isReflCo co' = go e
| otherwise = Cast (go e) co'
where
co' = optCoercion (getTCvSubst subst) co
go (Let bind body) = case simple_opt_bind env bind of
(env', Nothing) -> simple_opt_expr env' body
(env', Just bind) -> Let bind (simple_opt_expr env' body)
go lam@(Lam {}) = go_lam env [] lam
go (Case e b ty as)
-- See Note [Getting the map/coerce RULE to work]
| isDeadBinder b
, Just (con, _tys, es) <- exprIsConApp_maybe in_scope_env e'
, Just (altcon, bs, rhs) <- findAlt (DataAlt con) as
= case altcon of
DEFAULT -> go rhs
_ -> foldr wrapLet (simple_opt_expr env' rhs) mb_prs
where
(env', mb_prs) = mapAccumL simple_out_bind env $
zipEqual "simpleOptExpr" bs es
-- Note [Getting the map/coerce RULE to work]
| isDeadBinder b
, [(DEFAULT, _, rhs)] <- as
, isCoercionType (varType b)
, (Var fun, _args) <- collectArgs e
, fun `hasKey` coercibleSCSelIdKey
-- without this last check, we get #11230
= go rhs
| otherwise
= Case e' b' (substTy subst ty)
(map (go_alt env') as)
where
e' = go e
(env', b') = subst_opt_bndr env b
----------------------
go_alt env (con, bndrs, rhs)
= (con, bndrs', simple_opt_expr env' rhs)
where
(env', bndrs') = subst_opt_bndrs env bndrs
----------------------
-- go_lam tries eta reduction
go_lam env bs' (Lam b e)
= go_lam env' (b':bs') e
where
(env', b') = subst_opt_bndr env b
go_lam env bs' e
| Just etad_e <- tryEtaReduce bs e' = etad_e
| otherwise = mkLams bs e'
where
bs = reverse bs'
e' = simple_opt_expr env e
----------------------
-- simple_app collects arguments for beta reduction
simple_app :: SimpleOptEnv -> InExpr -> [SimpleClo] -> CoreExpr
simple_app env (Var v) as
| Just (env', e) <- lookupVarEnv (soe_inl env) v
= simple_app (soeSetInScope env env') e as
| let unf = idUnfolding v
, isCompulsoryUnfolding (idUnfolding v)
, isAlwaysActive (idInlineActivation v)
-- See Note [Unfold compulsory unfoldings in LHSs]
= simple_app (soeZapSubst env) (unfoldingTemplate unf) as
| otherwise
, let out_fn = lookupIdSubst (text "simple_app") (soe_subst env) v
= finish_app env out_fn as
simple_app env (App e1 e2) as
= simple_app env e1 ((env, e2) : as)
simple_app env (Lam b e) (a:as)
= wrapLet mb_pr (simple_app env' e as)
where
(env', mb_pr) = simple_bind_pair env b Nothing a
simple_app env (Tick t e) as
-- Okay to do "(Tick t e) x ==> Tick t (e x)"?
| t `tickishScopesLike` SoftScope
= mkTick t $ simple_app env e as
simple_app env e as
= finish_app env (simple_opt_expr env e) as
finish_app :: SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr
finish_app _ fun []
= fun
finish_app env fun (arg:args)
= finish_app env (App fun (simple_opt_clo env arg)) args
----------------------
simple_opt_bind :: SimpleOptEnv -> InBind
-> (SimpleOptEnv, Maybe OutBind)
simple_opt_bind env (NonRec b r)
= (env', case mb_pr of
Nothing -> Nothing
Just (b,r) -> Just (NonRec b r))
where
(b', r') = joinPointBinding_maybe b r `orElse` (b, r)
(env', mb_pr) = simple_bind_pair env b' Nothing (env,r')
simple_opt_bind env (Rec prs)
= (env'', res_bind)
where
res_bind = Just (Rec (reverse rev_prs'))
prs' = joinPointBindings_maybe prs `orElse` prs
(env', bndrs') = subst_opt_bndrs env (map fst prs')
(env'', rev_prs') = foldl do_pr (env', []) (prs' `zip` bndrs')
do_pr (env, prs) ((b,r), b')
= (env', case mb_pr of
Just pr -> pr : prs
Nothing -> prs)
where
(env', mb_pr) = simple_bind_pair env b (Just b') (env,r)
----------------------
simple_bind_pair :: SimpleOptEnv
-> InVar -> Maybe OutVar
-> SimpleClo
-> (SimpleOptEnv, Maybe (OutVar, OutExpr))
-- (simple_bind_pair subst in_var out_rhs)
-- either extends subst with (in_var -> out_rhs)
-- or returns Nothing
simple_bind_pair env@(SOE { soe_inl = inl_env, soe_subst = subst })
in_bndr mb_out_bndr clo@(rhs_env, in_rhs)
| Type ty <- in_rhs -- let a::* = TYPE ty in <body>
, let out_ty = substTy (soe_subst rhs_env) ty
= ASSERT( isTyVar in_bndr )
(env { soe_subst = extendTvSubst subst in_bndr out_ty }, Nothing)
| Coercion co <- in_rhs
, let out_co = optCoercion (getTCvSubst (soe_subst rhs_env)) co
= ASSERT( isCoVar in_bndr )
(env { soe_subst = extendCvSubst subst in_bndr out_co }, Nothing)
| pre_inline_unconditionally
= (env { soe_inl = extendVarEnv inl_env in_bndr clo }, Nothing)
| otherwise
= simple_out_bind_pair env in_bndr mb_out_bndr
(simple_opt_clo env clo)
occ active stable_unf
where
stable_unf = isStableUnfolding (idUnfolding in_bndr)
active = isAlwaysActive (idInlineActivation in_bndr)
occ = idOccInfo in_bndr
pre_inline_unconditionally :: Bool
pre_inline_unconditionally
| isCoVar in_bndr = False -- See Note [Do not inline CoVars unconditionally]
| isExportedId in_bndr = False -- in SimplUtils
| stable_unf = False
| not active = False -- Note [Inline prag in simplOpt]
| not (safe_to_inline occ) = False
| otherwise = True
-- Unconditionally safe to inline
safe_to_inline :: OccInfo -> Bool
safe_to_inline (IAmALoopBreaker {}) = False
safe_to_inline IAmDead = True
safe_to_inline occ@(OneOcc {}) = not (occ_in_lam occ)
&& occ_one_br occ
safe_to_inline (ManyOccs {}) = False
-------------------
simple_out_bind :: SimpleOptEnv -> (InVar, OutExpr)
-> (SimpleOptEnv, Maybe (OutVar, OutExpr))
simple_out_bind env@(SOE { soe_subst = subst }) (in_bndr, out_rhs)
| Type out_ty <- out_rhs
= ASSERT( isTyVar in_bndr )
(env { soe_subst = extendTvSubst subst in_bndr out_ty }, Nothing)
| Coercion out_co <- out_rhs
= ASSERT( isCoVar in_bndr )
(env { soe_subst = extendCvSubst subst in_bndr out_co }, Nothing)
| otherwise
= simple_out_bind_pair env in_bndr Nothing out_rhs
(idOccInfo in_bndr) True False
-------------------
simple_out_bind_pair :: SimpleOptEnv
-> InId -> Maybe OutId -> OutExpr
-> OccInfo -> Bool -> Bool
-> (SimpleOptEnv, Maybe (OutVar, OutExpr))
simple_out_bind_pair env in_bndr mb_out_bndr out_rhs
occ_info active stable_unf
| post_inline_unconditionally
= ( env' { soe_subst = extendIdSubst (soe_subst env) in_bndr out_rhs }
, Nothing)
| otherwise
= ( env', Just (out_bndr, out_rhs) )
where
(env', bndr1) = case mb_out_bndr of
Just out_bndr -> (env, out_bndr)
Nothing -> subst_opt_bndr env in_bndr
out_bndr = add_info env' in_bndr bndr1
post_inline_unconditionally :: Bool
post_inline_unconditionally
| not active = False
| isWeakLoopBreaker occ_info = False -- If it's a loop-breaker of any kind, don't inline
-- because it might be referred to "earlier"
| stable_unf = False -- Note [Stable unfoldings and postInlineUnconditionally]
| isExportedId in_bndr = False -- Note [Exported Ids and trivial RHSs]
| exprIsTrivial out_rhs = True
| coercible_hack = True
| otherwise = False
-- See Note [Getting the map/coerce RULE to work]
coercible_hack | (Var fun, args) <- collectArgs out_rhs
, Just dc <- isDataConWorkId_maybe fun
, dc `hasKey` heqDataConKey || dc `hasKey` coercibleDataConKey
= all exprIsTrivial args
| otherwise
= False
{- Note [Exported Ids and trivial RHSs]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We obviously do not want to unconditionally inline an Id that is exported.
In SimplUtils, Note [Top level and postInlineUnconditionally], we
explain why we don't inline /any/ top-level things unconditionally, even
trivial ones. But we do here! Why? In the simple optimiser
* We do no rule rewrites
* We do no call-site inlining
Those differences obviate the reasons for not inlining a trivial rhs,
and increase the benefit for doing so. So we unconditionally inline trivial
rhss here.
-}
----------------------
subst_opt_bndrs :: SimpleOptEnv -> [InVar] -> (SimpleOptEnv, [OutVar])
subst_opt_bndrs env bndrs = mapAccumL subst_opt_bndr env bndrs
subst_opt_bndr :: SimpleOptEnv -> InVar -> (SimpleOptEnv, OutVar)
subst_opt_bndr env bndr
| isTyVar bndr = (env { soe_subst = subst_tv }, tv')
| isCoVar bndr = (env { soe_subst = subst_cv }, cv')
| otherwise = subst_opt_id_bndr env bndr
where
subst = soe_subst env
(subst_tv, tv') = substTyVarBndr subst bndr
(subst_cv, cv') = substCoVarBndr subst bndr
subst_opt_id_bndr :: SimpleOptEnv -> InId -> (SimpleOptEnv, OutId)
-- Nuke all fragile IdInfo, unfolding, and RULES;
-- it gets added back later by add_info
-- Rather like SimplEnv.substIdBndr
--
-- It's important to zap fragile OccInfo (which CoreSubst.substIdBndr
-- carefully does not do) because simplOptExpr invalidates it
subst_opt_id_bndr (SOE { soe_subst = subst, soe_inl = inl }) old_id
= (SOE { soe_subst = new_subst, soe_inl = new_inl }, new_id)
where
Subst in_scope id_subst tv_subst cv_subst = subst
id1 = uniqAway in_scope old_id
id2 = setIdType id1 (substTy subst (idType old_id))
new_id = zapFragileIdInfo id2
-- Zaps rules, worker-info, unfolding, and fragile OccInfo
-- The unfolding and rules will get added back later, by add_info
new_in_scope = in_scope `extendInScopeSet` new_id
no_change = new_id == old_id
-- Extend the substitution if the unique has changed,
-- See the notes with substTyVarBndr for the delSubstEnv
new_id_subst
| no_change = delVarEnv id_subst old_id
| otherwise = extendVarEnv id_subst old_id (Var new_id)
new_subst = Subst new_in_scope new_id_subst tv_subst cv_subst
new_inl = delVarEnv inl old_id
----------------------
add_info :: SimpleOptEnv -> InVar -> OutVar -> OutVar
add_info env old_bndr new_bndr
| isTyVar old_bndr = new_bndr
| otherwise = maybeModifyIdInfo mb_new_info new_bndr
where
subst = soe_subst env
mb_new_info = substIdInfo subst new_bndr (idInfo old_bndr)
simpleUnfoldingFun :: IdUnfoldingFun
simpleUnfoldingFun id
| isAlwaysActive (idInlineActivation id) = idUnfolding id
| otherwise = noUnfolding
wrapLet :: Maybe (Id,CoreExpr) -> CoreExpr -> CoreExpr
wrapLet Nothing body = body
wrapLet (Just (b,r)) body = Let (NonRec b r) body
------------------
substVects :: Subst -> [CoreVect] -> [CoreVect]
substVects subst = map (substVect subst)
------------------
substVect :: Subst -> CoreVect -> CoreVect
substVect subst (Vect v rhs) = Vect v (simpleOptExprWith subst rhs)
substVect _subst vd@(NoVect _) = vd
substVect _subst vd@(VectType _ _ _) = vd
substVect _subst vd@(VectClass _) = vd
substVect _subst vd@(VectInst _) = vd
{-
Note [Inline prag in simplOpt]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If there's an INLINE/NOINLINE pragma that restricts the phase in
which the binder can be inlined, we don't inline here; after all,
we don't know what phase we're in. Here's an example
foo :: Int -> Int -> Int
{-# INLINE foo #-}
foo m n = inner m
where
{-# INLINE [1] inner #-}
inner m = m+n
bar :: Int -> Int
bar n = foo n 1
When inlining 'foo' in 'bar' we want the let-binding for 'inner'
to remain visible until Phase 1
Note [Unfold compulsory unfoldings in LHSs]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When the user writes `RULES map coerce = coerce` as a rule, the rule
will only ever match if simpleOptExpr replaces coerce by its unfolding
on the LHS, because that is the core that the rule matching engine
will find. So do that for everything that has a compulsory
unfolding. Also see Note [Desugaring coerce as cast] in Desugar.
However, we don't want to inline 'seq', which happens to also have a
compulsory unfolding, so we only do this unfolding only for things
that are always-active. See Note [User-defined RULES for seq] in MkId.
Note [Getting the map/coerce RULE to work]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We wish to allow the "map/coerce" RULE to fire:
{-# RULES "map/coerce" map coerce = coerce #-}
The naive core produced for this is
forall a b (dict :: Coercible * a b).
map @a @b (coerce @a @b @dict) = coerce @[a] @[b] @dict'
where dict' :: Coercible [a] [b]
dict' = ...