import DynFlags
import SimplMonad
-import Type hiding ( substTy, extendTvSubst )
+import Type hiding ( substTy, extendTvSubst, substTyVar )
import SimplEnv
import SimplUtils
import FamInstEnv ( FamInstEnv )
import Id
-import MkId ( mkImpossibleExpr, seqId )
+import MkId ( seqId, realWorldPrimId )
+import MkCore ( mkImpossibleExpr )
import Var
import IdInfo
import Name ( mkSystemVarName, isExternalName )
import Coercion
+import OptCoercion ( optCoercion )
import FamInstEnv ( topNormaliseType )
import DataCon ( DataCon, dataConWorkId, dataConRepStrictness )
import CoreMonad ( SimplifierSwitch(..), Tick(..) )
import BasicTypes ( isMarkedStrict, Arity )
import CostCentre ( currentCCS, pushCCisNop )
import TysPrim ( realWorldStatePrimTy )
-import PrelInfo ( realWorldPrimId )
import BasicTypes ( TopLevelFlag(..), isTopLevel, RecFlag(..) )
import MonadUtils ( foldlM, mapAccumLM )
import Maybes ( orElse )
-- Simplify the RHS
; (body_env1, body1) <- simplExprF body_env body mkRhsStop
-- ANF-ise a constructor or PAP rhs
- ; (body_env2, body2) <- prepareRhs body_env1 bndr1 body1
+ ; (body_env2, body2) <- prepareRhs top_lvl body_env1 bndr1 body1
; (env', rhs')
<- if not (doFloatFromRhs top_lvl is_rec False body2 body_env2)
- then -- No floating, just wrap up!
- do { rhs' <- mkLam env tvs' (wrapFloats body_env2 body2)
+ then -- No floating, revert to body1
+ do { rhs' <- mkLam env tvs' (wrapFloats body_env1 body1)
; return (env, rhs') }
else if null tvs then -- Simple floating
= return env -- Here b is dead, and we avoid creating
| otherwise -- the binding b = (a,b)
= do { (env', bndr') <- simplBinder env bndr
- ; completeNonRecX env' (isStrictId bndr) bndr bndr' new_rhs }
+ ; completeNonRecX NotTopLevel env' (isStrictId bndr) bndr bndr' new_rhs }
+ -- simplNonRecX is only used for NotTopLevel things
-completeNonRecX :: SimplEnv
+completeNonRecX :: TopLevelFlag -> SimplEnv
-> Bool
-> InId -- Old binder
-> OutId -- New binder
-> OutExpr -- Simplified RHS
-> SimplM SimplEnv
-completeNonRecX env is_strict old_bndr new_bndr new_rhs
- = do { (env1, rhs1) <- prepareRhs (zapFloats env) new_bndr new_rhs
+completeNonRecX top_lvl env is_strict old_bndr new_bndr new_rhs
+ = do { (env1, rhs1) <- prepareRhs top_lvl (zapFloats env) new_bndr new_rhs
; (env2, rhs2) <-
if doFloatFromRhs NotTopLevel NonRecursive is_strict rhs1 env1
then do { tick LetFloatFromLet
That's what the 'go' loop in prepareRhs does
\begin{code}
-prepareRhs :: SimplEnv -> OutId -> OutExpr -> SimplM (SimplEnv, OutExpr)
+prepareRhs :: TopLevelFlag -> SimplEnv -> OutId -> OutExpr -> SimplM (SimplEnv, OutExpr)
-- Adds new floats to the env iff that allows us to return a good RHS
-prepareRhs env id (Cast rhs co) -- Note [Float coercions]
+prepareRhs top_lvl env id (Cast rhs co) -- Note [Float coercions]
| (ty1, _ty2) <- coercionKind co -- Do *not* do this if rhs has an unlifted type
, not (isUnLiftedType ty1) -- see Note [Float coercions (unlifted)]
- = do { (env', rhs') <- makeTrivialWithInfo env sanitised_info rhs
+ = do { (env', rhs') <- makeTrivialWithInfo top_lvl env sanitised_info rhs
; return (env', Cast rhs' co) }
where
sanitised_info = vanillaIdInfo `setStrictnessInfo` strictnessInfo info
`setDemandInfo` demandInfo info
info = idInfo id
-prepareRhs env0 _ rhs0
+prepareRhs top_lvl env0 _ rhs0
= do { (_is_exp, env1, rhs1) <- go 0 env0 rhs0
; return (env1, rhs1) }
where
go n_val_args env (App fun arg)
= do { (is_exp, env', fun') <- go (n_val_args+1) env fun
; case is_exp of
- True -> do { (env'', arg') <- makeTrivial env' arg
+ True -> do { (env'', arg') <- makeTrivial top_lvl env' arg
; return (True, env'', App fun' arg') }
False -> return (False, env, App fun arg) }
go n_val_args env (Var fun)
\begin{code}
-makeTrivial :: SimplEnv -> OutExpr -> SimplM (SimplEnv, OutExpr)
+makeTrivial :: TopLevelFlag -> SimplEnv -> OutExpr -> SimplM (SimplEnv, OutExpr)
-- Binds the expression to a variable, if it's not trivial, returning the variable
-makeTrivial env expr = makeTrivialWithInfo env vanillaIdInfo expr
+makeTrivial top_lvl env expr = makeTrivialWithInfo top_lvl env vanillaIdInfo expr
-makeTrivialWithInfo :: SimplEnv -> IdInfo -> OutExpr -> SimplM (SimplEnv, OutExpr)
+makeTrivialWithInfo :: TopLevelFlag -> SimplEnv -> IdInfo
+ -> OutExpr -> SimplM (SimplEnv, OutExpr)
-- Propagate strictness and demand info to the new binder
-- Note [Preserve strictness when floating coercions]
-makeTrivialWithInfo env info expr
- | exprIsTrivial expr
+-- Returned SimplEnv has same substitution as incoming one
+makeTrivialWithInfo top_lvl env info expr
+ | exprIsTrivial expr -- Already trivial
+ || not (bindingOk top_lvl expr expr_ty) -- Cannot trivialise
+ -- See Note [Cannot trivialise]
= return (env, expr)
| otherwise -- See Note [Take care] below
= do { uniq <- getUniqueM
; let name = mkSystemVarName uniq (fsLit "a")
- var = mkLocalIdWithInfo name (exprType expr) info
- ; env' <- completeNonRecX env False var var expr
- ; return (env', substExpr env' (Var var)) }
- -- The substitution is needed becase we're constructing a new binding
+ var = mkLocalIdWithInfo name expr_ty info
+ ; env' <- completeNonRecX top_lvl env False var var expr
+ ; expr' <- simplVar env' var
+ ; return (env', expr') }
+ -- The simplVar is needed becase we're constructing a new binding
-- a = rhs
-- And if rhs is of form (rhs1 |> co), then we might get
-- a1 = rhs1
-- a = a1 |> co
-- and now a's RHS is trivial and can be substituted out, and that
-- is what completeNonRecX will do
+ -- To put it another way, it's as if we'd simplified
+ -- let var = e in var
+ where
+ expr_ty = exprType expr
+
+bindingOk :: TopLevelFlag -> CoreExpr -> Type -> Bool
+-- True iff we can have a binding of this expression at this level
+-- Precondition: the type is the type of the expression
+bindingOk top_lvl _ expr_ty
+ | isTopLevel top_lvl = not (isUnLiftedType expr_ty)
+ | otherwise = True
\end{code}
+Note [Cannot trivialise]
+~~~~~~~~~~~~~~~~~~~~~~~~
+Consider tih
+ f :: Int -> Addr#
+
+ foo :: Bar
+ foo = Bar (f 3)
+
+Then we can't ANF-ise foo, even though we'd like to, because
+we can't make a top-level binding for the Addr# (f 3). And if
+so we don't want to turn it into
+ foo = let x = f 3 in Bar x
+because we'll just end up inlining x back, and that makes the
+simplifier loop. Better not to ANF-ise it at all.
+
+A case in point is literal strings (a MachStr is not regarded as
+trivial):
+
+ foo = Ptr "blob"#
+
+We don't want to ANF-ise this.
%************************************************************************
%* *
in
ASSERT( isId new_bndr )
WARN( new_arity < old_arity || new_arity < dmd_arity,
- (ptext (sLit "Arity decrease:") <+> ppr final_id <+> ppr old_arity
- <+> ppr new_arity <+> ppr dmd_arity) )
+ (ptext (sLit "Arity decrease:") <+> (ppr final_id <+> ppr old_arity
+ <+> ppr new_arity <+> ppr dmd_arity) $$ ppr new_rhs) )
-- Note [Arity decrease]
final_id `seq` -- This seq forces the Id, and hence its IdInfo,
-> OccInfo -> OutExpr
-> Unfolding -> SimplM Unfolding
-- Note [Setting the new unfolding]
-simplUnfolding env _ _ _ _ (DFunUnfolding con ops)
- = return (DFunUnfolding con ops')
+simplUnfolding env _ _ _ _ (DFunUnfolding ar con ops)
+ = return (DFunUnfolding ar con ops')
where
- ops' = map (CoreSubst.substExpr (mkCoreSubst env)) ops
+ ops' = map (substExpr (text "simplUnfolding") env) ops
simplUnfolding env top_lvl id _ _
(CoreUnfolding { uf_tmpl = expr, uf_arity = arity
, uf_src = src, uf_guidance = guide })
| isInlineRuleSource src
- = -- pprTrace "su" (vcat [ppr id, ppr act, ppr (getMode env), ppr (getMode rule_env)]) $
- do { expr' <- simplExpr rule_env expr
- ; let src' = CoreSubst.substUnfoldingSource (mkCoreSubst env) src
+ = do { expr' <- simplExpr rule_env expr
+ ; let src' = CoreSubst.substUnfoldingSource (mkCoreSubst (text "inline-unf") env) src
; return (mkCoreUnfolding (isTopLevel top_lvl) src' expr' arity guide) }
-- See Note [Top-level flag on inline rules] in CoreUnfold
where
simplExprF' :: SimplEnv -> InExpr -> SimplCont
-> SimplM (SimplEnv, OutExpr)
-simplExprF' env (Var v) cont = simplVar env v cont
+simplExprF' env (Var v) cont = simplVarF env v cont
simplExprF' env (Lit lit) cont = rebuild env (Lit lit) cont
simplExprF' env (Note n expr) cont = simplNote env n expr cont
simplExprF' env (Cast body co) cont = simplCast env body co cont
n_params = length bndrs
(bndrs, body) = collectBinders expr
zap | n_args >= n_params = \b -> b
- | otherwise = \b -> if isTyVar b then b
+ | otherwise = \b -> if isTyCoVar b then b
else zapLamIdInfo b
-- NB: we count all the args incl type args
-- so we must count all the binders (incl type lambdas)
-- (->) t1 t2 ~ (->) s1 s2
[co1, co2] = decomposeCo 2 co
new_arg = mkCoerce (mkSymCoercion co1) arg'
- arg' = substExpr (arg_se `setInScope` env) arg
+ arg' = substExpr (text "move-cast") (arg_se `setInScope` env) arg
add_coerce co _ cont = CoerceIt co cont
\end{code}
-- First deal with type applications and type lets
-- (/\a. e) (Type ty) and (let a = Type ty in e)
simplNonRecE env bndr (Type ty_arg, rhs_se) (bndrs, body) cont
- = ASSERT( isTyVar bndr )
+ = ASSERT( isTyCoVar bndr )
do { ty_arg' <- simplType (rhs_se `setInScope` env) ty_arg
; simplLam (extendTvSubst env bndr ty_arg') bndrs body cont }
(StrictBind bndr bndrs body env cont) }
| otherwise
- = ASSERT( not (isTyVar bndr) )
+ = ASSERT( not (isTyCoVar bndr) )
do { (env1, bndr1) <- simplNonRecBndr env bndr
; let (env2, bndr2) = addBndrRules env1 bndr bndr1
; env3 <- simplLazyBind env2 NotTopLevel NonRecursive bndr bndr2 rhs rhs_se
%************************************************************************
%* *
-\subsection{Dealing with calls}
+ Variables
%* *
%************************************************************************
\begin{code}
-simplVar :: SimplEnv -> Id -> SimplCont -> SimplM (SimplEnv, OutExpr)
-simplVar env var cont
+simplVar :: SimplEnv -> InVar -> SimplM OutExpr
+-- Look up an InVar in the environment
+simplVar env var
+ | isTyCoVar var
+ = return (Type (substTyVar env var))
+ | otherwise
+ = case substId env var of
+ DoneId var1 -> return (Var var1)
+ DoneEx e -> return e
+ ContEx tvs ids e -> simplExpr (setSubstEnv env tvs ids) e
+
+simplVarF :: SimplEnv -> InId -> SimplCont -> SimplM (SimplEnv, OutExpr)
+simplVarF env var cont
= case substId env var of
DoneEx e -> simplExprF (zapSubstEnv env) e cont
ContEx tvs ids e -> simplExprF (setSubstEnv env tvs ids) e cont
completeCall env var cont
= do { ------------- Try inlining ----------------
dflags <- getDOptsSmpl
- ; let (args,call_cont) = contArgs cont
+ ; let (lone_variable, arg_infos, call_cont) = contArgs cont
-- The args are OutExprs, obtained by *lazily* substituting
-- in the args found in cont. These args are only examined
-- to limited depth (unless a rule fires). But we must do
-- the substitution; rule matching on un-simplified args would
-- be bogus
- arg_infos = [interestingArg arg | arg <- args, isValArg arg]
n_val_args = length arg_infos
interesting_cont = interestingCallContext call_cont
unfolding = activeUnfolding env var
maybe_inline = callSiteInline dflags var unfolding
- (null args) arg_infos interesting_cont
+ lone_variable arg_infos interesting_cont
; case maybe_inline of {
- Just unfolding -- There is an inlining!
+ Just expr -- There is an inlining!
-> do { tick (UnfoldingDone var)
- ; trace_inline dflags unfolding args call_cont $
- simplExprF (zapSubstEnv env) unfolding cont }
+ ; trace_inline dflags expr cont $
+ simplExprF (zapSubstEnv env) expr cont }
; Nothing -> do -- No inlining!
; rebuildCall env info cont
}}}
where
- trace_inline dflags unfolding args call_cont stuff
+ trace_inline dflags unfolding cont stuff
| not (dopt Opt_D_dump_inlinings dflags) = stuff
| not (dopt Opt_D_verbose_core2core dflags)
= if isExternalName (idName var) then
else stuff
| otherwise
= pprTrace ("Inlining done: " ++ showSDoc (ppr var))
- (vcat [text "Before:" <+> ppr var <+> sep (map pprParendExpr args),
- text "Inlined fn: " <+> nest 2 (ppr unfolding),
- text "Cont: " <+> ppr call_cont])
+ (vcat [text "Inlined fn: " <+> nest 2 (ppr unfolding),
+ text "Cont: " <+> ppr cont])
stuff
rebuildCall :: SimplEnv
rebuildCase env scrut case_bndr alts@[(_, bndrs, rhs)] cont
| all isDeadBinder (case_bndr : bndrs) -- So this is just 'seq'
- = do { let rhs' = substExpr env rhs
+ = do { let rhs' = substExpr (text "rebuild-case") env rhs
out_args = [Type (substTy env (idType case_bndr)),
Type (exprType rhs'), scrut, rhs']
-- Lazily evaluated, so we don't do most of this
-- it does not return an environment
simplAlts env scrut case_bndr alts cont'
- = -- pprTrace "simplAlts" (ppr alts $$ ppr (seIdSubst env)) $
+ = -- pprTrace "simplAlts" (ppr alts $$ ppr (seTvSubst env)) $
do { let env0 = zapFloats env
; (env1, case_bndr1) <- simplBinder env0 case_bndr
= go vs the_strs
where
go [] [] = []
- go (v:vs') strs | isTyVar v = v : go vs' strs
+ go (v:vs') strs | isTyCoVar v = v : go vs' strs
go (v:vs') (str:strs)
| isMarkedStrict str = evald_v : go vs' strs
| otherwise = zapped_v : go vs' strs
-> SimplM (SimplEnv, OutExpr)
knownCon env scrut dc dc_ty_args dc_args bndr bs rhs cont
- = do { env' <- bind_args env bs dc_args
- ; let
- -- It's useful to bind bndr to scrut, rather than to a fresh
- -- binding x = Con arg1 .. argn
- -- because very often the scrut is a variable, so we avoid
- -- creating, and then subsequently eliminating, a let-binding
- -- BUT, if scrut is a not a variable, we must be careful
- -- about duplicating the arg redexes; in that case, make
- -- a new con-app from the args
- bndr_rhs | exprIsTrivial scrut = scrut
- | otherwise = con_app
- con_app = Var (dataConWorkId dc)
- `mkTyApps` dc_ty_args
- `mkApps` [substExpr env' (varToCoreExpr b) | b <- bs]
- -- dc_ty_args are aready OutTypes, but bs are InBndrs
-
- ; env'' <- simplNonRecX env' bndr bndr_rhs
+ = do { env' <- bind_args env bs dc_args
+ ; env'' <- bind_case_bndr env'
; simplExprF env'' rhs cont }
where
zap_occ = zapCasePatIdOcc bndr -- bndr is an InId
bind_args env' [] _ = return env'
bind_args env' (b:bs') (Type ty : args)
- = ASSERT( isTyVar b )
+ = ASSERT( isTyCoVar b )
bind_args (extendTvSubst env' b ty) bs' args
bind_args env' (b:bs') (arg : args)
pprPanic "bind_args" $ ppr dc $$ ppr bs $$ ppr dc_args $$
text "scrut:" <+> ppr scrut
+ -- It's useful to bind bndr to scrut, rather than to a fresh
+ -- binding x = Con arg1 .. argn
+ -- because very often the scrut is a variable, so we avoid
+ -- creating, and then subsequently eliminating, a let-binding
+ -- BUT, if scrut is a not a variable, we must be careful
+ -- about duplicating the arg redexes; in that case, make
+ -- a new con-app from the args
+ bind_case_bndr env
+ | isDeadBinder bndr = return env
+ | exprIsTrivial scrut = return (extendIdSubst env bndr (DoneEx scrut))
+ | otherwise = do { dc_args <- mapM (simplVar env) bs
+ -- dc_ty_args are aready OutTypes,
+ -- but bs are InBndrs
+ ; let con_app = Var (dataConWorkId dc)
+ `mkTyApps` dc_ty_args
+ `mkApps` dc_args
+ ; simplNonRecX env bndr con_app }
+
-------------------
missingAlt :: SimplEnv -> Id -> [InAlt] -> SimplCont -> SimplM (SimplEnv, OutExpr)
-- This isn't strictly an error, although it is unusual.
mkDupableCont env (StrictArg info cci cont)
-- See Note [Duplicating StrictArg]
= do { (env', dup, nodup) <- mkDupableCont env cont
- ; (env'', args') <- mapAccumLM makeTrivial env' (ai_args info)
+ ; (env'', args') <- mapAccumLM (makeTrivial NotTopLevel) env' (ai_args info)
; return (env'', StrictArg (info { ai_args = args' }) cci dup, nodup) }
mkDupableCont env (ApplyTo _ arg se cont)
-- in [...hole...] a
do { (env', dup_cont, nodup_cont) <- mkDupableCont env cont
; arg' <- simplExpr (se `setInScope` env') arg
- ; (env'', arg'') <- makeTrivial env' arg'
+ ; (env'', arg'') <- makeTrivial NotTopLevel env' arg'
; let app_cont = ApplyTo OkToDup arg'' (zapSubstEnv env'') dup_cont
; return (env'', app_cont, nodup_cont) }
DataAlt dc -> setIdUnfolding case_bndr unf
where
-- See Note [Case binders and join points]
- unf = mkInlineRule needSaturated rhs 0
+ unf = mkInlineRule rhs Nothing
rhs = mkConApp dc (map Type (tyConAppArgs scrut_ty)
++ varsToCoreExprs bndrs')
| otherwise = bndrs' ++ [case_bndr_w_unf]
abstract_over bndr
- | isTyVar bndr = True -- Abstract over all type variables just in case
+ | isTyCoVar bndr = True -- Abstract over all type variables just in case
| otherwise = not (isDeadBinder bndr)
-- The deadness info on the new Ids is preserved by simplBinders
but that is bad if 'c' is *not* later scrutinised.
So instead we do both: we pass 'c' and 'c#' , and record in c's inlining
-that it's really I# c#, thus
+(an InlineRule) that it's really I# c#, thus
$j = \c# -> \c[=I# c#] -> ...c....
Absence analysis may later discard 'c'.
+NB: take great care when doing strictness analysis;
+ see Note [Lamba-bound unfoldings] in DmdAnal.
+
+Also note that we can still end up passing stuff that isn't used. Before
+strictness analysis we have
+ let $j x y c{=(x,y)} = (h c, ...)
+ in ...
+After strictness analysis we see that h is strict, we end up with
+ let $j x y c{=(x,y)} = ($wh x y, ...)
+and c is unused.
Note [Duplicated env]
~~~~~~~~~~~~~~~~~~~~~
projects / ghc-hetmet.git / blobdiff