import PprCore ( pprParendExpr, pprCoreExpr )
import CoreUnfold ( mkUnfolding, callSiteInline, CallCtxt(..) )
import CoreUtils
+import CoreArity ( exprArity )
import Rules ( lookupRule, getRules )
import BasicTypes ( isMarkedStrict )
import CostCentre ( currentCCS )
; (env', rhs')
<- if not (doFloatFromRhs top_lvl is_rec False body2 body_env2)
then -- No floating, just wrap up!
- do { rhs' <- mkLam tvs' (wrapFloats body_env2 body2)
+ do { rhs' <- mkLam env tvs' (wrapFloats body_env2 body2)
; return (env, rhs') }
else if null tvs then -- Simple floating
else -- Do type-abstraction first
do { tick LetFloatFromLet
; (poly_binds, body3) <- abstractFloats tvs' body_env2 body2
- ; rhs' <- mkLam tvs' body3
+ ; rhs' <- mkLam env tvs' body3
; let env' = foldl (addPolyBind top_lvl) env poly_binds
; return (env', rhs') }
where
is_val = n_val_args > 0 -- There is at least one arg
-- ...and the fun a constructor or PAP
- && (isDataConWorkId fun || n_val_args < idArity fun)
+ && (isConLikeId fun || n_val_args < idArity fun)
go _ env other
= return (False, env, other)
\end{code}
= return (addNonRecWithUnf env new_bndr new_rhs unfolding wkr)
where
unfolding | omit_unfolding = NoUnfolding
- | otherwise = mkUnfolding (isTopLevel top_lvl) new_rhs
+ | otherwise = mkUnfolding (isTopLevel top_lvl) new_rhs
old_info = idInfo old_bndr
occ_info = occInfo old_info
wkr = substWorker env (workerInfo old_info)
addNonRecWithUnf env new_bndr rhs unfolding wkr
= ASSERT( isId new_bndr )
WARN( new_arity < old_arity || new_arity < dmd_arity,
- (ppr final_id <+> ppr old_arity <+> ppr new_arity <+> ppr dmd_arity) $$ ppr rhs )
+ (ptext (sLit "Arity decrease:") <+> ppr final_id <+> ppr old_arity
+ <+> ppr new_arity <+> ppr dmd_arity) $$ ppr rhs )
+ -- Note [Arity decrease]
final_id `seq` -- This seq forces the Id, and hence its IdInfo,
-- and hence any inner substitutions
addNonRec env final_id rhs
final_id = new_bndr `setIdInfo` final_info
\end{code}
+Note [Arity decrease]
+~~~~~~~~~~~~~~~~~~~~~
+Generally speaking the arity of a binding should not decrease. But it *can*
+legitimately happen becuase of RULES. Eg
+ f = g Int
+where g has arity 2, will have arity 2. But if there's a rewrite rule
+ g Int --> h
+where h has arity 1, then f's arity will decrease. Here's a real-life example,
+which is in the output of Specialise:
+
+ Rec {
+ $dm {Arity 2} = \d.\x. op d
+ {-# RULES forall d. $dm Int d = $s$dm #-}
+
+ dInt = MkD .... opInt ...
+ opInt {Arity 1} = $dm dInt
+
+ $s$dm {Arity 0} = \x. op dInt }
+
+Here opInt has arity 1; but when we apply the rule its arity drops to 0.
+That's why Specialise goes to a little trouble to pin the right arity
+on specialised functions too.
%************************************************************************
simplLam env bndrs body cont
= do { (env', bndrs') <- simplLamBndrs env bndrs
; body' <- simplExpr env' body
- ; new_lam <- mkLam bndrs' body'
+ ; new_lam <- mkLam env' bndrs' body'
; rebuild env' new_lam cont }
------------------
Just unfolding -- There is an inlining!
-> do { tick (UnfoldingDone var)
; (if dopt Opt_D_dump_inlinings dflags then
- pprTrace ("Inlining done" ++ showSDoc (ppr var)) (vcat [
+ 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])
LiberateCase gets to see it.)
-Historical note [no-case-of-case]
-~~~~~~~~~~~~~~~~~~~~~~
-We *used* to suppress the binder-swap in case expressoins when
--fno-case-of-case is on. Old remarks:
- "This happens in the first simplifier pass,
- and enhances full laziness. Here's the bad case:
- f = \ y -> ...(case x of I# v -> ...(case x of ...) ... )
- If we eliminate the inner case, we trap it inside the I# v -> arm,
- which might prevent some full laziness happening. I've seen this
- in action in spectral/cichelli/Prog.hs:
- [(m,n) | m <- [1..max], n <- [1..max]]
- Hence the check for NoCaseOfCase."
-However, now the full-laziness pass itself reverses the binder-swap, so this
-check is no longer necessary.
-
-Historical note [Suppressing the case binder-swap]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-There is another situation when it might make sense to suppress the
-case-expression binde-swap. If we have
-
- case x of w1 { DEFAULT -> case x of w2 { A -> e1; B -> e2 }
- ...other cases .... }
-
-We'll perform the binder-swap for the outer case, giving
-
- case x of w1 { DEFAULT -> case w1 of w2 { A -> e1; B -> e2 }
- ...other cases .... }
-
-But there is no point in doing it for the inner case, because w1 can't
-be inlined anyway. Furthermore, doing the case-swapping involves
-zapping w2's occurrence info (see paragraphs that follow), and that
-forces us to bind w2 when doing case merging. So we get
-
- case x of w1 { A -> let w2 = w1 in e1
- B -> let w2 = w1 in e2
- ...other cases .... }
-
-This is plain silly in the common case where w2 is dead.
-
-Even so, I can't see a good way to implement this idea. I tried
-not doing the binder-swap if the scrutinee was already evaluated
-but that failed big-time:
-
- data T = MkT !Int
-
- case v of w { MkT x ->
- case x of x1 { I# y1 ->
- case x of x2 { I# y2 -> ...
-
-Notice that because MkT is strict, x is marked "evaluated". But to
-eliminate the last case, we must either make sure that x (as well as
-x1) has unfolding MkT y1. THe straightforward thing to do is to do
-the binder-swap. So this whole note is a no-op.
\begin{code}
projects / ghc-hetmet.git / blobdiff