\section[SimplUtils]{The simplifier utilities}
\begin{code}
+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
module SimplUtils (
-- Rebuilding
mkLam, mkCase, prepareAlts, bindCaseBndr,
-- The continuation type
SimplCont(..), DupFlag(..), LetRhsFlag(..),
contIsDupable, contResultType, contIsTrivial, contArgs, dropArgs,
- countValArgs, countArgs,
+ countValArgs, countArgs, splitInlineCont,
mkBoringStop, mkLazyArgStop, mkRhsStop, contIsRhsOrArg,
interestingCallContext, interestingArgContext,
import Var ( isCoVar )
import NewDemand
import SimplMonad
-import Type
+import Type hiding( substTy )
import TyCon
import DataCon
import Unify ( dataConCannotMatch )
mkRhsStop :: OutType -> SimplCont
mkRhsStop ty = Stop ty AnRhs (canUpdateInPlace ty)
-contIsRhsOrArg (Stop {}) = True
-contIsRhsOrArg (StrictBind {}) = True
-contIsRhsOrArg (StrictArg {}) = True
-contIsRhsOrArg other = False
+-------------------
+contIsRhsOrArg (Stop {}) = True
+contIsRhsOrArg (StrictBind {}) = True
+contIsRhsOrArg (StrictArg {}) = True
+contIsRhsOrArg other = False
-------------------
contIsDupable :: SimplCont -> Bool
dropArgs 0 cont = cont
dropArgs n (ApplyTo _ _ _ cont) = dropArgs (n-1) cont
dropArgs n other = pprPanic "dropArgs" (ppr n <+> ppr other)
+
+--------------------
+splitInlineCont :: SimplCont -> Maybe (SimplCont, SimplCont)
+-- Returns Nothing if the continuation should dissolve an InlineMe Note
+-- Return Just (c1,c2) otherwise,
+-- where c1 is the continuation to put inside the InlineMe
+-- and c2 outside
+
+-- Example: (__inline_me__ (/\a. e)) ty
+-- Here we want to do the beta-redex without dissolving the InlineMe
+-- See test simpl017 (and Trac #1627) for a good example of why this is important
+
+splitInlineCont (ApplyTo dup (Type ty) se c)
+ | Just (c1, c2) <- splitInlineCont c = Just (ApplyTo dup (Type ty) se c1, c2)
+splitInlineCont cont@(Stop ty _ _) = Just (mkBoringStop ty, cont)
+splitInlineCont cont@(StrictBind bndr _ _ se _) = Just (mkBoringStop (substTy se (idType bndr)), cont)
+splitInlineCont cont@(StrictArg _ fun_ty _ _) = Just (mkBoringStop (funArgTy fun_ty), cont)
+splitInlineCont other = Nothing
+ -- NB: the calculation of the type for mkBoringStop is an annoying
+ -- duplication of the same calucation in mkDupableCont
\end{code}
contIsInteresting looks for case expressions with just a single
default case.
+
\begin{code}
-interestingCallContext :: Bool -- False <=> no args at all
- -> Bool -- False <=> no value args
- -> SimplCont -> Bool
- -- The "lone-variable" case is important. I spent ages
- -- messing about with unsatisfactory varaints, but this is nice.
- -- The idea is that if a variable appear all alone
- -- as an arg of lazy fn, or rhs Stop
- -- as scrutinee of a case Select
- -- as arg of a strict fn ArgOf
- -- then we should not inline it (unless there is some other reason,
- -- e.g. is is the sole occurrence). We achieve this by making
- -- interestingCallContext return False for a lone variable.
- --
- -- Why? At least in the case-scrutinee situation, turning
- -- let x = (a,b) in case x of y -> ...
- -- into
- -- let x = (a,b) in case (a,b) of y -> ...
- -- and thence to
- -- let x = (a,b) in let y = (a,b) in ...
- -- is bad if the binding for x will remain.
- --
- -- Another example: I discovered that strings
- -- were getting inlined straight back into applications of 'error'
- -- because the latter is strict.
- -- s = "foo"
- -- f = \x -> ...(error s)...
-
- -- Fundamentally such contexts should not ecourage inlining because
- -- the context can ``see'' the unfolding of the variable (e.g. case or a RULE)
- -- so there's no gain.
- --
- -- However, even a type application or coercion isn't a lone variable.
- -- Consider
- -- case $fMonadST @ RealWorld of { :DMonad a b c -> c }
- -- We had better inline that sucker! The case won't see through it.
- --
- -- For now, I'm treating treating a variable applied to types
- -- in a *lazy* context "lone". The motivating example was
- -- f = /\a. \x. BIG
- -- g = /\a. \y. h (f a)
- -- There's no advantage in inlining f here, and perhaps
- -- a significant disadvantage. Hence some_val_args in the Stop case
-
-interestingCallContext some_args some_val_args cont
+interestingCallContext :: SimplCont -> CallContInfo
+interestingCallContext cont
= interesting cont
where
- interesting (Select {}) = some_args
- interesting (ApplyTo {}) = True -- Can happen if we have (coerce t (f x)) y
+ interesting (Select _ bndr _ _ _)
+ | isDeadBinder bndr = CaseCont
+ | otherwise = InterestingCont
+
+ interesting (ApplyTo {}) = InterestingCont
+ -- Can happen if we have (coerce t (f x)) y
-- Perhaps True is a bit over-keen, but I've
-- seen (coerce f) x, where f has an INLINE prag,
- -- So we have to give some motivaiton for inlining it
- interesting (StrictArg {}) = some_val_args
- interesting (StrictBind {}) = some_val_args -- ??
- interesting (Stop ty _ interesting) = some_val_args && interesting
- interesting (CoerceIt _ cont) = interesting cont
+ -- So we have to give some motivation for inlining it
+ interesting (StrictArg {}) = InterestingCont
+ interesting (StrictBind {}) = InterestingCont
+ interesting (Stop ty _ yes) = if yes then InterestingCont else BoringCont
+ interesting (CoerceIt _ cont) = interesting cont
-- If this call is the arg of a strict function, the context
-- is a bit interesting. If we inline here, we may get useful
-- evaluation information to avoid repeated evals: e.g.
-- where g has rules, then we *do* want to inline f, in case it
-- exposes a rule that might fire. Similarly, if the context is
-- h (g (f x x))
--- where h has rules, then we do want to inline f.
+-- where h has rules, then we do want to inline f; hence the
+-- call_cont argument to interestingArgContext
+--
-- The interesting_arg_ctxt flag makes this happen; if it's
-- set, the inliner gets just enough keener to inline f
-- regardless of how boring f's arguments are, if it's marked INLINE
-- The alternative would be to *always* inline an INLINE function,
-- regardless of how boring its context is; but that seems overkill
-- For example, it'd mean that wrapper functions were always inlined
-interestingArgContext fn cont
- = idHasRules fn || go cont
+interestingArgContext fn call_cont
+ = idHasRules fn || go call_cont
where
go (Select {}) = False
go (ApplyTo {}) = False
might have a BIG rhs, which will now be dup'd at every occurrenc of x.
-Evne RHSs labelled InlineMe aren't caught here, because there might be
+Even RHSs labelled InlineMe aren't caught here, because there might be
no benefit from inlining at the call site.
[Sept 01] Don't unconditionally inline a top-level thing, because that
; mkLam' dflags bndrs body }
where
mkLam' :: DynFlags -> [OutBndr] -> OutExpr -> SimplM OutExpr
- mkLam' dflags bndrs (Cast body@(Lam _ _) co)
+ mkLam' dflags bndrs (Cast body co)
+ | not (any bad bndrs)
-- Note [Casts and lambdas]
- = do { lam <- mkLam' dflags (bndrs ++ bndrs') body'
+ = do { lam <- mkLam' dflags bndrs body
; return (mkCoerce (mkPiTypes bndrs co) lam) }
- where
- (bndrs',body') = collectBinders body
+ where
+ co_vars = tyVarsOfType co
+ bad bndr = isCoVar bndr && bndr `elemVarSet` co_vars
mkLam' dflags bndrs body
| dopt Opt_DoEtaReduction dflags,
(\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.
-
+In general, this floats casts outside lambdas, where (I hope) they
+might meet and cancel with some other cast:
+ \x. e `cast` co ===> (\x. e) `cast` (tx -> co)
+ /\a. e `cast` co ===> (/\a. e) `cast` (/\a. co)
+ /\g. e `cast` co ===> (/\g. e) `cast` (/\g. co)
+ (if not (g `in` co))
+
+Notice that it works regardless of 'e'. Originally it worked only
+if 'e' was itself a lambda, but in some cases that resulted in
+fruitless iteration in the simplifier. A good example was when
+compiling Text.ParserCombinators.ReadPrec, where we had a definition
+like (\x. Get `cast` g)
+where Get is a constructor with nonzero arity. Then mkLam eta-expanded
+the Get, and the next iteration eta-reduced it, and then eta-expanded
+it again.
+
+Note also the side condition for the case of coercion binders.
+It does not make sense to transform
+ /\g. e `cast` g ==> (/\g.e) `cast` (/\g.g)
+because the latter is not well-kinded.
-- c) floating lets out through big lambdas
-- [only if all tyvar lambdas, and only if this lambda
pattern in each alternative, so the binder-info is rather useful.
\begin{code}
-prepareAlts :: OutExpr -> OutId -> [InAlt] -> SimplM ([AltCon], [InAlt])
-prepareAlts scrut case_bndr' alts
+prepareAlts :: SimplEnv -> OutExpr -> OutId -> [InAlt] -> SimplM ([AltCon], [InAlt])
+prepareAlts env scrut case_bndr' alts
= do { dflags <- getDOptsSmpl
; alts <- combineIdenticalAlts case_bndr' alts
-- EITHER by the context,
-- OR by a non-DEFAULT branch in this case expression.
- ; default_alts <- prepareDefault dflags scrut case_bndr' mb_tc_app
+ ; default_alts <- prepareDefault dflags env case_bndr' mb_tc_app
imposs_deflt_cons maybe_deflt
; let trimmed_alts = filterOut impossible_alt alts_wo_default
-- Prepare the default alternative
-------------------------------------------------------------------------
prepareDefault :: DynFlags
- -> OutExpr -- Scrutinee
+ -> SimplEnv
-> OutId -- Case binder; need just for its type. Note that as an
-- OutId, it has maximum information; this is important.
-- Test simpl013 is an example
-- And becuase case-merging can cause many to show up
------- Merge nested cases ----------
-prepareDefault dflags scrut outer_bndr bndr_ty imposs_cons (Just deflt_rhs)
+prepareDefault dflags env outer_bndr bndr_ty imposs_cons (Just deflt_rhs)
| dopt Opt_CaseMerge dflags
- , Case (Var scrut_var) inner_bndr _ inner_alts <- deflt_rhs
- , scruting_same_var scrut_var
+ , Case (Var inner_scrut_var) inner_bndr _ inner_alts <- deflt_rhs
+ , DoneId inner_scrut_var' <- substId env inner_scrut_var
+ -- Remember, inner_scrut_var is an InId, but outer_bndr is an OutId
+ , inner_scrut_var' == outer_bndr
+ -- NB: the substId means that if the outer scrutinee was a
+ -- variable, and inner scrutinee is the same variable,
+ -- then inner_scrut_var' will be outer_bndr
+ -- via the magic of simplCaseBinder
= do { tick (CaseMerge outer_bndr)
; let munge_rhs rhs = bindCaseBndr inner_bndr (Var outer_bndr) rhs
-- mkCase applied to them, so they won't have a case in their default
-- Secondly, if you do, you get an infinite loop, because the bindCaseBndr
-- in munge_rhs may put a case into the DEFAULT branch!
- where
- -- We are scrutinising the same variable if it's
- -- the outer case-binder, or if the outer case scrutinises a variable
- -- (and it's the same). Testing both allows us not to replace the
- -- outer scrut-var with the outer case-binder (Simplify.simplCaseBinder).
- scruting_same_var = case scrut of
- Var outer_scrut -> \ v -> v == outer_bndr || v == outer_scrut
- other -> \ v -> v == outer_bndr
+
--------- Fill in known constructor -----------
-prepareDefault dflags scrut case_bndr (Just (tycon, inst_tys)) imposs_cons (Just deflt_rhs)
+prepareDefault dflags env case_bndr (Just (tycon, inst_tys)) imposs_cons (Just deflt_rhs)
| -- This branch handles the case where we are
-- scrutinisng an algebraic data type
isAlgTyCon tycon -- It's a data type, tuple, or unboxed tuples.
two_or_more -> return [(DEFAULT, [], deflt_rhs)]
--------- Catch-all cases -----------
-prepareDefault dflags scrut case_bndr bndr_ty imposs_cons (Just deflt_rhs)
+prepareDefault dflags env case_bndr bndr_ty imposs_cons (Just deflt_rhs)
= return [(DEFAULT, [], deflt_rhs)]
-prepareDefault dflags scrut case_bndr bndr_ty imposs_cons Nothing
+prepareDefault dflags env case_bndr bndr_ty imposs_cons Nothing
= return [] -- No default branch
\end{code}
projects / ghc-hetmet.git / blobdiff