{- $$ nest 2 (pprSimplEnv se) -}) $$ ppr cont
ppr (StrictBind b _ _ _ cont) = (ptext (sLit "StrictBind") <+> ppr b) $$ ppr cont
ppr (StrictArg ai _ cont) = (ptext (sLit "StrictArg") <+> ppr (ai_fun ai)) $$ ppr cont
- ppr (Select dup bndr alts _ cont) = (ptext (sLit "Select") <+> ppr dup <+> ppr bndr) $$
- (nest 4 (ppr alts)) $$ ppr cont
+ ppr (Select dup bndr alts se cont) = (ptext (sLit "Select") <+> ppr dup <+> ppr bndr) $$
+ (nest 2 $ vcat [ppr (seTvSubst se), ppr alts]) $$ ppr cont
ppr (CoerceIt co cont) = (ptext (sLit "CoerceIt") <+> ppr co) $$ ppr cont
data DupFlag = OkToDup | NoDup
countArgs (ApplyTo _ _ _ cont) = 1 + countArgs cont
countArgs _ = 0
-contArgs :: SimplCont -> ([OutExpr], SimplCont)
+contArgs :: SimplCont -> (Bool, [ArgSummary], SimplCont)
-- Uses substitution to turn each arg into an OutExpr
-contArgs cont = go [] cont
+contArgs cont@(ApplyTo {})
+ = case go [] cont of { (args, cont') -> (False, args, cont') }
where
- go args (ApplyTo _ arg se cont) = go (substExpr se arg : args) cont
- go args cont = (reverse args, cont)
+ go args (ApplyTo _ arg se cont)
+ | isTypeArg arg = go args cont
+ | otherwise = go (is_interesting arg se : args) cont
+ go args cont = (reverse args, cont)
+
+ is_interesting arg se = interestingArg (substExpr (text "contArgs") se arg)
+ -- Do *not* use short-cutting substitution here
+ -- because we want to get as much IdInfo as possible
+
+contArgs cont = (True, [], cont)
pushArgs :: SimplEnv -> [CoreExpr] -> SimplCont -> SimplCont
pushArgs _env [] cont = cont
InlineRule, because then recursive knots in instance declarations
don't get unravelled.
-However, *sometimes* SimplGently must do no call-site inlining at all.
-Before full laziness we must be careful not to inline wrappers,
-because doing so inhibits floating
+However, *sometimes* SimplGently must do no call-site inlining at all
+(hence sm_inline = False). Before full laziness we must be careful
+not to inline wrappers, because doing so inhibits floating
e.g. ...(case f x of ...)...
==> ...(case (case x of I# x# -> fw x#) of ...)...
==> ...(case x of I# x# -> case fw x# of ...)...
to work in Template Haskell when simplifying
splices, so we get simpler code for literal strings
+But watch out: list fusion can prevent floating. So use phase control
+to switch off those rules until after floating.
+
Note [Simplifying inside InlineRules]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We must take care with simplification inside InlineRules (which come from
However, as usual for Gentle mode, do not inline things that are
inactive in the intial stages. See Note [Gentle mode].
+Note [InlineRule and preInlineUnconditionally]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Surprisingly, do not pre-inline-unconditionally Ids with INLINE pragmas!
+Example
+
+ {-# INLINE f #-}
+ f :: Eq a => a -> a
+ f x = ...
+
+ fInt :: Int -> Int
+ fInt = f Int dEqInt
+
+ ...fInt...fInt...fInt...
+
+Here f occurs just once, in the RHS of f1. But if we inline it there
+we'll lose the opportunity to inline at each of fInt's call sites.
+The INLINE pragma will only inline when the application is saturated
+for exactly this reason; and we don't want PreInlineUnconditionally
+to second-guess it. A live example is Trac #3736.
+ c.f. Note [InlineRule and postInlineUnconditionally]
+
Note [Top-level botomming Ids]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Don't inline top-level Ids that are bottoming, even if they are used just
preInlineUnconditionally :: SimplEnv -> TopLevelFlag -> InId -> InExpr -> Bool
preInlineUnconditionally env top_lvl bndr rhs
| not active = False
+ | isStableUnfolding (idUnfolding bndr) = False -- Note [InlineRule and preInlineUnconditionally]
| isTopLevel top_lvl && isBottomingId bndr = False -- Note [Top-level bottoming Ids]
| opt_SimplNoPreInlining = False
| otherwise = case idOccInfo bndr of
and now postInlineUnconditionally, losing the InlineRule on f. Now f'
won't inline because 'e' is too big.
+ c.f. Note [InlineRule and preInlineUnconditionally]
+
%************************************************************************
%* *
mkLam _b [] body
= return body
-mkLam env bndrs body
+mkLam _env bndrs body
= do { dflags <- getDOptsSmpl
; mkLam' dflags bndrs body }
where
co_vars = tyVarsOfType co
bad bndr = isCoVar bndr && bndr `elemVarSet` co_vars
+ mkLam' dflags bndrs body@(Lam {})
+ = mkLam' dflags (bndrs ++ bndrs1) body1
+ where
+ (bndrs1, body1) = collectBinders body
+
mkLam' dflags bndrs body
| dopt Opt_DoEtaReduction dflags,
Just etad_lam <- tryEtaReduce bndrs body
; return etad_lam }
| dopt Opt_DoLambdaEtaExpansion dflags,
- not (inGentleMode env), -- In gentle mode don't eta-expansion
- any isRuntimeVar bndrs -- because it can clutter up the code
- -- with casts etc that may not be removed
+ not (all isTyVar bndrs) -- Don't eta expand type abstractions
= do { let body' = tryEtaExpansion dflags body
; return (mkLams bndrs body') }
abstractFloats main_tvs body_env body
= ASSERT( notNull body_floats )
do { (subst, float_binds) <- mapAccumLM abstract empty_subst body_floats
- ; return (float_binds, CoreSubst.substExpr subst body) }
+ ; return (float_binds, CoreSubst.substExpr (text "abstract_floats1") subst body) }
where
main_tv_set = mkVarSet main_tvs
body_floats = getFloats body_env
subst' = CoreSubst.extendIdSubst subst id poly_app
; return (subst', (NonRec poly_id poly_rhs)) }
where
- rhs' = CoreSubst.substExpr subst rhs
+ rhs' = CoreSubst.substExpr (text "abstract_floats2") subst rhs
tvs_here | any isCoVar main_tvs = main_tvs -- Note [Abstract over coercions]
| otherwise
= varSetElems (main_tv_set `intersectVarSet` exprSomeFreeVars isTyVar rhs')
abstract subst (Rec prs)
= do { (poly_ids, poly_apps) <- mapAndUnzipM (mk_poly tvs_here) ids
; let subst' = CoreSubst.extendSubstList subst (ids `zip` poly_apps)
- poly_rhss = [mkLams tvs_here (CoreSubst.substExpr subst' rhs) | rhs <- rhss]
+ poly_rhss = [mkLams tvs_here (CoreSubst.substExpr (text "abstract_floats3") subst' rhs)
+ | rhs <- rhss]
; return (subst', Rec (poly_ids `zip` poly_rhss)) }
where
(ids,rhss) = unzip prs
projects / ghc-hetmet.git / blobdiff