mkBoringStop, mkLazyArgStop, mkRhsStop, contIsRhsOrArg,
interestingCallContext, interestingArgContext,
- interestingArg, isStrictBndr, mkArgInfo
+ interestingArg, mkArgInfo
) where
#include "HsVersions.h"
import DynFlags
import StaticFlags
import CoreSyn
+import PprCore
import CoreFVs
import CoreUtils
import Literal
instance Outputable SimplCont where
ppr (Stop ty is_rhs _) = ptext SLIT("Stop") <> brackets (ppr is_rhs) <+> ppr ty
- ppr (ApplyTo dup arg se cont) = (ptext SLIT("ApplyTo") <+> ppr dup <+> ppr arg) $$ ppr cont
+ ppr (ApplyTo dup arg se cont) = ((ptext SLIT("ApplyTo") <+> ppr dup <+> pprParendExpr arg) $$
+ nest 2 (pprSimplEnv se)) $$ ppr cont
ppr (StrictBind b _ _ _ cont) = (ptext SLIT("StrictBind") <+> ppr b) $$ ppr cont
ppr (StrictArg f _ _ cont) = (ptext SLIT("StrictArg") <+> ppr f) $$ ppr cont
ppr (Select dup bndr alts se cont) = (ptext SLIT("Select") <+> ppr dup <+> ppr bndr) $$
- (nest 4 (ppr alts $$ ppr (seIdSubst se))) $$ ppr cont
+ (nest 4 (ppr alts $$ pprSimplEnv se)) $$ ppr cont
ppr (CoerceIt co cont) = (ptext SLIT("CoerceIt") <+> ppr co) $$ ppr cont
data DupFlag = OkToDup | NoDup
interestingArg (Type _) = False
interestingArg (App fn (Type _)) = interestingArg fn
interestingArg (Note _ a) = interestingArg a
+
+-- Idea (from Sam B); I'm not sure if it's a good idea, so commented out for now
+-- interestingArg expr | isUnLiftedType (exprType expr)
+-- -- Unlifted args are only ever interesting if we know what they are
+-- = case expr of
+-- Lit lit -> True
+-- _ -> False
+
interestingArg other = True
-- Consider let x = 3 in f x
-- The substitution will contain (x -> ContEx 3), and we want to
-- to work in Template Haskell when simplifying
-- splices, so we get simpler code for literal strings
SimplPhase n -> Just (isActive n)
-\end{code}
+\end{code}
%************************************************************************
= do { dflags <- getDOptsSmpl
; mkLam' dflags bndrs body }
where
+ mkLam' :: DynFlags -> [OutBndr] -> OutExpr -> SimplM OutExpr
+ mkLam' dflags bndrs (Cast body@(Lam _ _) co)
+ -- Note [Casts and lambdas]
+ = do { lam <- mkLam' dflags (bndrs ++ bndrs') body'
+ ; return (mkCoerce (mkPiTypes bndrs co) lam) }
+ where
+ (bndrs',body') = collectBinders body
+
mkLam' dflags bndrs body
| dopt Opt_DoEtaReduction dflags,
Just etad_lam <- tryEtaReduce bndrs body
= returnSmpl (mkLams bndrs body)
\end{code}
+Note [Casts and lambdas]
+~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+ (\x. (\y. e) `cast` g1) `cast` g2
+There is a danger here that the two lambdas look separated, and the
+full laziness pass might float an expression to between the two.
+
+So this equation in mkLam' floats the g1 out, thus:
+ (\x. e `cast` g1) --> (\x.e) `cast` (tx -> g1)
+where x:tx.
+
+In general, this floats casts outside lambdas, where (I hope) they might meet
+and cancel with some other cast.
+
+
-- c) floating lets out through big lambdas
-- [only if all tyvar lambdas, and only if this lambda
-- is the RHS of a let]
other -> ...(case x of
0# -> ...
other -> ...) ...
-\end{code}
+\end{verbatim}
Here the inner case can be eliminated. This really only shows up in
eliminating error-checking code.