\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 MkId
import Name
import Id
+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}
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
subst' = CoreSubst.extendIdSubst subst id poly_app
; return (subst', (NonRec poly_id poly_rhs)) }
where
- rhs' = CoreSubst.substExpr subst rhs
- tvs_here = varSetElems (main_tv_set `intersectVarSet` exprSomeFreeVars isTyVar rhs')
+ rhs' = CoreSubst.substExpr subst rhs
+ tvs_here | any isCoVar main_tvs = main_tvs -- Note [Abstract over coercions]
+ | otherwise
+ = varSetElems (main_tv_set `intersectVarSet` exprSomeFreeVars isTyVar rhs')
+
-- Abstract only over the type variables free in the rhs
-- wrt which the new binding is abstracted. But the naive
-- approach of abstract wrt the tyvars free in the Id's type
-- pinned on x.
\end{code}
+Note [Abstract over coercions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If a coercion variable (g :: a ~ Int) is free in the RHS, then so is the
+type variable a. Rather than sort this mess out, we simply bale out and abstract
+wrt all the type variables if any of them are coercion variables.
+
+
Historical note: if you use let-bindings instead of a substitution, beware of this:
-- Suppose we start with:
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