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 )
+import Name ( mkSystemVarName, isExternalName )
import Coercion
+import OptCoercion ( optCoercion )
import FamInstEnv ( topNormaliseType )
import DataCon ( DataCon, dataConWorkId, dataConRepStrictness )
+import CoreMonad ( SimplifierSwitch(..), Tick(..) )
import CoreSyn
import Demand ( isStrictDmd, splitStrictSig )
import PprCore ( pprParendExpr, pprCoreExpr )
-import CoreUnfold ( mkUnfolding, mkCoreUnfolding, mkInlineRule,
- exprIsConApp_maybe, callSiteInline, CallCtxt(..) )
+import CoreUnfold ( mkUnfolding, mkCoreUnfolding
+ , mkInlineUnfolding, mkSimpleUnfolding
+ , exprIsConApp_maybe, callSiteInline, CallCtxt(..) )
import CoreUtils
import qualified CoreSubst
import CoreArity ( exprArity )
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 )
-> SimplM SimplEnv
simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se
- = do { let rhs_env = rhs_se `setInScope` env
+ = -- pprTrace "simplLazyBind" ((ppr bndr <+> ppr bndr1) $$ ppr rhs $$ ppr (seIdSubst rhs_se)) $
+ do { let rhs_env = rhs_se `setInScope` env
(tvs, body) = case collectTyBinders rhs of
(tvs, body) | not_lam body -> (tvs,body)
| otherwise -> ([], rhs)
-- 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
- ; (env2, rhs2) <-
+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
; return (addFloats env env1, rhs1) } -- Add the floats to the main env
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
+ | isStableSource src
= do { expr' <- simplExpr rule_env expr
- ; let src' = CoreSubst.substUnfoldingSource (mkCoreSubst env) src
- ; return (mkCoreUnfolding (isTopLevel top_lvl) src' expr' arity guide) }
+ ; let src' = CoreSubst.substUnfoldingSource (mkCoreSubst (text "inline-unf") env) src
+ is_top_lvl = isTopLevel top_lvl
+ ; case guide of
+ UnfIfGoodArgs{} ->
+ return (mkUnfolding src' is_top_lvl (isBottomingId id) expr')
+ -- If the guidance is UnfIfGoodArgs, this is an INLINABLE
+ -- unfolding, and we need to make sure the guidance is kept up
+ -- to date with respect to any changes in the unfolding.
+ _other ->
+ return (mkCoreUnfolding src' is_top_lvl expr' arity guide)
-- See Note [Top-level flag on inline rules] in CoreUnfold
+ }
where
- rule_env = updMode (updModeForInlineRules (idInlineActivation id)) env
- -- See Note [Simplifying gently inside InlineRules] in SimplUtils
+ act = idInlineActivation id
+ rule_env = updMode (updModeForInlineRules act) env
+ -- See Note [Simplifying inside InlineRules] in SimplUtils
simplUnfolding _ top_lvl id _occ_info new_rhs _
- = return (mkUnfolding (isTopLevel top_lvl) (isBottomingId id) new_rhs)
+ = return (mkUnfolding InlineRhs (isTopLevel top_lvl) (isBottomingId id) new_rhs)
-- We make an unfolding *even for loop-breakers*.
-- Reason: (a) It might be useful to know that they are WHNF
-- (b) In TidyPgm we currently assume that, if we want to
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)
| otherwise
= -- If case-of-case is off, simply simplify the case expression
-- in a vanilla Stop context, and rebuild the result around it
- do { case_expr' <- simplExprC env scrut case_cont
+ do { case_expr' <- simplExprC env scrut
+ (Select NoDup bndr alts env mkBoringStop)
; rebuild env case_expr' cont }
- where
- case_cont = Select NoDup bndr alts env mkBoringStop
simplExprF' env (Let (Rec pairs) body) cont
= do { env' <- simplRecBndrs env (map fst pairs)
StrictArg info _ cont -> rebuildCall env (info `addArgTo` expr) cont
StrictBind b bs body se cont -> do { env' <- simplNonRecX (se `setFloats` env) b expr
; simplLam env' bs body cont }
- ApplyTo _ arg se cont -> do { arg' <- simplExpr (se `setInScope` env) arg
+ ApplyTo dup_flag arg se cont -- See Note [Avoid redundant simplification]
+ | isSimplified dup_flag -> rebuild env (App expr arg) cont
+ | otherwise -> do { arg' <- simplExpr (se `setInScope` env) arg
; rebuild env (App expr arg') cont }
\end{code}
-- (->) 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 }
simplNonRecE env bndr (rhs, rhs_se) (bndrs, body) cont
| preInlineUnconditionally env NotTopLevel bndr rhs
= do { tick (PreInlineUnconditionally bndr)
- ; simplLam (extendIdSubst env bndr (mkContEx rhs_se rhs)) bndrs body cont }
+ ; -- pprTrace "preInlineUncond" (ppr bndr <+> ppr rhs) $
+ simplLam (extendIdSubst env bndr (mkContEx rhs_se rhs)) bndrs body cont }
| isStrictId bndr
= do { simplExprF (rhs_se `setFloats` env) rhs
(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
rebuildCall env info@(ArgInfo { ai_encl = encl_rules
, ai_strs = str:strs, ai_discs = disc:discs })
- (ApplyTo _ arg arg_se cont)
+ (ApplyTo dup_flag arg arg_se cont)
+ | isSimplified dup_flag -- See Note [Avoid redundant simplification]
+ = rebuildCall env (addArgTo info' arg) cont
+
| str -- Strict argument
= -- pprTrace "Strict Arg" (ppr arg $$ ppr (seIdSubst env) $$ ppr (seInScope env)) $
simplExprF (arg_se `setFloats` env) arg
; mb_rule <- tryRules env rules fun args cont
; case mb_rule of {
Just (n_args, rule_rhs) -> simplExprF env' rule_rhs $
- pushArgs env' (drop n_args args) cont ;
+ pushSimplifiedArgs env' (drop n_args args) cont ;
-- n_args says how many args the rule consumed
; Nothing -> rebuild env (mkApps (Var fun) args) cont -- No rules
} }
It's very desirable to try RULES once the arguments have been simplified, because
doing so ensures that rule cascades work in one pass. Consider
{-# RULES g (h x) = k x
- f (k x) = x #-}
+ f (k x) = x #-}
...f (g (h x))...
Then we want to rewrite (g (h x)) to (k x) and only then try f's rules. If
we match f's rules against the un-simplified RHS, it won't match. This
op ($p1 ($p2 (df d)))
We want all this to unravel in one sweeep.
+Note [Avoid redundant simplification]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Because RULES apply to simplified arguments, there's a danger of repeatedly
+simplifying already-simplified arguments. An important example is that of
+ (>>=) d e1 e2
+Here e1, e2 are simplified before the rule is applied, but don't really
+participate in the rule firing. So we mark them as Simplified to avoid
+re-simplifying them.
+
Note [Shadowing]
~~~~~~~~~~~~~~~~
This part of the simplifier may break the no-shadowing invariant
rebuildCase env scrut case_bndr [(_, bndrs, rhs)] cont
-- See if we can get rid of the case altogether
- -- See Note [Case eliminiation]
+ -- See Note [Case elimination]
-- mkCase made sure that if all the alternatives are equal,
-- then there is now only one (DEFAULT) rhs
| all isDeadBinder bndrs -- bndrs are [InId]
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
addBinderUnfolding :: SimplEnv -> Id -> CoreExpr -> SimplEnv
addBinderUnfolding env bndr rhs
- = modifyInScope env (bndr `setIdUnfolding` mkUnfolding False False rhs)
+ = modifyInScope env (bndr `setIdUnfolding` mkSimpleUnfolding rhs)
addBinderOtherCon :: SimplEnv -> Id -> [AltCon] -> SimplEnv
addBinderOtherCon env bndr cons
-> 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 = mkInlineUnfolding Nothing rhs
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]
~~~~~~~~~~~~~~~~~~~~~
"see" the MkT any more, because it's big and won't get duplicated.
And, what is worse, nothing was gained by the case-of-case transform.
-When should use this case of mkDupableCont?
-However, matching on *any* single-alternative case is a *disaster*;
+So, in circumstances like these, we don't want to build join points
+and push the outer case into the branches of the inner one. Instead,
+don't duplicate the continuation.
+
+When should we use this strategy? We should not use it on *every*
+single-alternative case:
e.g. case (case ....) of (a,b) -> (# a,b #)
- We must push the outer case into the inner one!
+Here we must push the outer case into the inner one!
Other choices:
* Match [(DEFAULT,_,_)], but in the common case of Int,
the *un-simplified* rhs, which is fine. It might get bigger or
smaller after simplification; if it gets smaller, this case might
fire next time round. NB also that we must test contIsDupable
- case_cont *btoo, because case_cont might be big!
+ case_cont *too, because case_cont might be big!
HOWEVER: I found that this version doesn't work well, because
we can get let x = case (...) of { small } in ...case x...
projects / ghc-hetmet.git / blobdiff