X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FSimplUtils.lhs;h=b57b4b14265f7ae15e415e539cbb8cbdc100a841;hb=8a86866e9e382c1d4d06cad722ddbe965d09997c;hp=57c7274027e059697389d3c00f91d2139dc7c4fd;hpb=711e4d7a4d65472a3a1fb35bcad8e1c9a109c728;p=ghc-hetmet.git diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs index 57c7274..b57b4b1 100644 --- a/ghc/compiler/simplCore/SimplUtils.lhs +++ b/ghc/compiler/simplCore/SimplUtils.lhs @@ -7,7 +7,7 @@ module SimplUtils ( simplBinder, simplBinders, simplRecBndrs, simplLetBndr, simplLamBndrs, - newId, mkLam, mkCase, + newId, mkLam, prepareAlts, mkCase, -- The continuation type SimplCont(..), DupFlag(..), LetRhsFlag(..), @@ -25,25 +25,27 @@ import CmdLineOpts ( SimplifierSwitch(..), opt_SimplCaseMerge, opt_UF_UpdateInPlace ) import CoreSyn -import CoreUtils ( cheapEqExpr, exprType, - etaExpand, exprEtaExpandArity, bindNonRec, mkCoerce, +import CoreFVs ( exprFreeVars ) +import CoreUtils ( cheapEqExpr, exprType, exprIsTrivial, + etaExpand, exprEtaExpandArity, bindNonRec, mkCoerce2, findDefault, exprOkForSpeculation, exprIsValue ) import qualified Subst ( simplBndrs, simplBndr, simplLetId, simplLamBndr ) -import Id ( Id, idType, idInfo, +import Id ( Id, idType, idInfo, isDataConWorkId, mkSysLocal, isDeadBinder, idNewDemandInfo, idUnfolding, idNewStrictness ) import NewDemand ( isStrictDmd, isBotRes, splitStrictSig ) import SimplMonad -import Type ( Type, seqType, splitRepFunTys, isStrictType, +import Type ( Type, seqType, splitFunTys, dropForAlls, isStrictType, splitTyConApp_maybe, tyConAppArgs, mkTyVarTys ) import TcType ( isDictTy ) -import OccName ( UserFS ) +import OccName ( EncodedFS ) import TyCon ( tyConDataCons_maybe, isAlgTyCon, isNewTyCon ) -import DataCon ( dataConRepArity, dataConSig, dataConArgTys ) +import DataCon ( dataConRepArity, dataConExistentialTyVars, dataConArgTys ) import Var ( mkSysTyVar, tyVarKind ) +import VarSet import Util ( lengthExceeds, mapAccumL ) import Outputable \end{code} @@ -222,6 +224,9 @@ getContArgs chkr fun orig_cont -- * (error "Hello") arg -- * f (error "Hello") where f is strict -- etc + -- Then, especially in the first of these cases, we'd like to discard + -- the continuation, leaving just the bottoming expression. But the + -- type might not be right, so we may have to add a coerce. go acc ss inl cont | null ss && discardableCont cont = (reverse acc, discardCont cont, inl) | otherwise = (reverse acc, cont, inl) @@ -232,14 +237,14 @@ getContArgs chkr fun orig_cont computed_stricts = zipWith (||) fun_stricts arg_stricts ---------------------------- - (val_arg_tys, _) = splitRepFunTys (idType fun) + (val_arg_tys, _) = splitFunTys (dropForAlls (idType fun)) arg_stricts = map isStrictType val_arg_tys ++ repeat False -- These argument types are used as a cheap and cheerful way to find -- unboxed arguments, which must be strict. But it's an InType -- and so there might be a type variable where we expect a function -- type (the substitution hasn't happened yet). And we don't bother -- doing the type applications for a polymorphic function. - -- Hence the split*Rep*FunTys + -- Hence the splitFunTys*IgnoringForAlls* ---------------------------- -- If fun_stricts is finite, it means the function returns bottom @@ -273,6 +278,9 @@ interestingArg :: OutExpr -> Bool interestingArg (Var v) = hasSomeUnfolding (idUnfolding v) -- Was: isValueUnfolding (idUnfolding v') -- But that seems over-pessimistic + || isDataConWorkId v + -- This accounts for an argument like + -- () or [], which is definitely interesting interestingArg (Type _) = False interestingArg (App fn (Type _)) = interestingArg fn interestingArg (Note _ a) = interestingArg a @@ -471,7 +479,7 @@ seqBndr b | isTyVar b = b `seq` () \begin{code} -newId :: UserFS -> Type -> SimplM Id +newId :: EncodedFS -> Type -> SimplM Id newId fs ty = getUniqueSmpl `thenSmpl` \ uniq -> returnSmpl (mkSysLocal fs uniq ty) \end{code} @@ -540,17 +548,17 @@ tryEtaReduce bndrs body -- efficient here: -- (a) we already have the binders -- (b) we can do the triviality test before computing the free vars - -- [in fact I take the simple path and look for just a variable] = go (reverse bndrs) body where go (b : bs) (App fun arg) | ok_arg b arg = go bs fun -- Loop round - go [] (Var fun) | ok_fun fun = Just (Var fun) -- Success! + go [] fun | ok_fun fun = Just fun -- Success! go _ _ = Nothing -- Failure! - ok_fun fun = not (fun `elem` bndrs) && - (isEvaldUnfolding (idUnfolding fun) || all ok_lam bndrs) + ok_fun fun = exprIsTrivial fun + && not (any (`elemVarSet` (exprFreeVars fun)) bndrs) + && (exprIsValue fun || all ok_lam bndrs) ok_lam v = isTyVar v || isDictTy (idType v) - -- The isEvaldUnfolding is because eta reduction is not + -- The exprIsValue is because eta reduction is not -- valid in general: \x. bot /= bot -- So we need to be sure that the "fun" is a value. -- @@ -778,6 +786,132 @@ tryRhsTyLam env tyvars body -- Only does something if there's a let -} \end{code} +%************************************************************************ +%* * +\subsection{Case alternative filtering +%* * +%************************************************************************ + +prepareAlts does two things: + +1. Eliminate alternatives that cannot match, including the + DEFAULT alternative. + +2. If the DEFAULT alternative can match only one possible constructor, + then make that constructor explicit. + e.g. + case e of x { DEFAULT -> rhs } + ===> + case e of x { (a,b) -> rhs } + where the type is a single constructor type. This gives better code + when rhs also scrutinises x or e. + +It's a good idea do do this stuff before simplifying the alternatives, to +avoid simplifying alternatives we know can't happen, and to come up with +the list of constructors that are handled, to put into the IdInfo of the +case binder, for use when simplifying the alternatives. + +Eliminating the default alternative in (1) isn't so obvious, but it can +happen: + +data Colour = Red | Green | Blue + +f x = case x of + Red -> .. + Green -> .. + DEFAULT -> h x + +h y = case y of + Blue -> .. + DEFAULT -> [ case y of ... ] + +If we inline h into f, the default case of the inlined h can't happen. +If we don't notice this, we may end up filtering out *all* the cases +of the inner case y, which give us nowhere to go! + + +\begin{code} +prepareAlts :: OutExpr -- Scrutinee + -> InId -- Case binder + -> [InAlt] + -> SimplM ([InAlt], -- Better alternatives + [AltCon]) -- These cases are handled + +prepareAlts scrut case_bndr alts + = let + (alts_wo_default, maybe_deflt) = findDefault alts + + impossible_cons = case scrut of + Var v -> otherCons (idUnfolding v) + other -> [] + + -- Filter out alternatives that can't possibly match + better_alts | null impossible_cons = alts_wo_default + | otherwise = [alt | alt@(con,_,_) <- alts_wo_default, + not (con `elem` impossible_cons)] + + -- "handled_cons" are handled either by the context, + -- or by a branch in this case expression + -- (Don't add DEFAULT to the handled_cons!!) + handled_cons = impossible_cons ++ [con | (con,_,_) <- better_alts] + in + -- Filter out the default, if it can't happen, + -- or replace it with "proper" alternative if there + -- is only one constructor left + prepareDefault case_bndr handled_cons maybe_deflt `thenSmpl` \ deflt_alt -> + + returnSmpl (deflt_alt ++ better_alts, handled_cons) + +prepareDefault case_bndr handled_cons (Just rhs) + | Just (tycon, inst_tys) <- splitTyConApp_maybe (idType case_bndr), + isAlgTyCon tycon, -- It's a data type, tuple, or unboxed tuples. + not (isNewTyCon tycon), -- We can have a newtype, if we are just doing an eval: + -- case x of { DEFAULT -> e } + -- and we don't want to fill in a default for them! + Just all_cons <- tyConDataCons_maybe tycon, + not (null all_cons), -- This is a tricky corner case. If the data type has no constructors, + -- which GHC allows, then the case expression will have at most a default + -- alternative. We don't want to eliminate that alternative, because the + -- invariant is that there's always one alternative. It's more convenient + -- to leave + -- case x of { DEFAULT -> e } + -- as it is, rather than transform it to + -- error "case cant match" + -- which would be quite legitmate. But it's a really obscure corner, and + -- not worth wasting code on. + let handled_data_cons = [data_con | DataAlt data_con <- handled_cons], + let missing_cons = [con | con <- all_cons, + not (con `elem` handled_data_cons)] + = case missing_cons of + [] -> returnSmpl [] -- Eliminate the default alternative + -- if it can't match + + [con] -> -- It matches exactly one constructor, so fill it in + tick (FillInCaseDefault case_bndr) `thenSmpl_` + mk_args con inst_tys `thenSmpl` \ args -> + returnSmpl [(DataAlt con, args, rhs)] + + two_or_more -> returnSmpl [(DEFAULT, [], rhs)] + + | otherwise + = returnSmpl [(DEFAULT, [], rhs)] + +prepareDefault case_bndr handled_cons Nothing + = returnSmpl [] + +mk_args missing_con inst_tys + = getUniquesSmpl `thenSmpl` \ tv_uniqs -> + getUniquesSmpl `thenSmpl` \ id_uniqs -> + let + ex_tyvars = dataConExistentialTyVars missing_con + ex_tyvars' = zipWith mk tv_uniqs ex_tyvars + mk uniq tv = mkSysTyVar uniq (tyVarKind tv) + arg_tys = dataConArgTys missing_con (inst_tys ++ mkTyVarTys ex_tyvars') + arg_ids = zipWith (mkSysLocal FSLIT("a")) id_uniqs arg_tys + in + returnSmpl (ex_tyvars' ++ arg_ids) +\end{code} + %************************************************************************ %* * @@ -788,10 +922,10 @@ tryRhsTyLam env tyvars body -- Only does something if there's a let mkCase puts a case expression back together, trying various transformations first. \begin{code} -mkCase :: OutExpr -> [AltCon] -> OutId -> [OutAlt] -> SimplM OutExpr +mkCase :: OutExpr -> OutId -> [OutAlt] -> SimplM OutExpr -mkCase scrut handled_cons case_bndr alts - = mkAlts scrut handled_cons case_bndr alts `thenSmpl` \ better_alts -> +mkCase scrut case_bndr alts + = mkAlts scrut case_bndr alts `thenSmpl` \ better_alts -> mkCase1 scrut case_bndr better_alts \end{code} @@ -814,16 +948,7 @@ mkAlts tries these things: a) all branches equal b) some branches equal to the DEFAULT (which occurs first) -2. If the DEFAULT alternative can match only one possible constructor, - then make that constructor explicit. - e.g. - case e of x { DEFAULT -> rhs } - ===> - case e of x { (a,b) -> rhs } - where the type is a single constructor type. This gives better code - when rhs also scrutinises x or e. - -3. Case merging: +2. Case merging: case e of b { ==> case e of b { p1 -> rhs1 p1 -> rhs1 ... ... @@ -866,7 +991,7 @@ and similarly in cascade for all the join points! -------------------------------------------------- -- 1. Merge identical branches -------------------------------------------------- -mkAlts scrut handled_cons case_bndr alts@((con1,bndrs1,rhs1) : con_alts) +mkAlts scrut case_bndr alts@((con1,bndrs1,rhs1) : con_alts) | all isDeadBinder bndrs1, -- Remember the default length filtered_alts < length con_alts -- alternative comes first = tick (AltMerge case_bndr) `thenSmpl_` @@ -878,43 +1003,10 @@ mkAlts scrut handled_cons case_bndr alts@((con1,bndrs1,rhs1) : con_alts) -------------------------------------------------- --- 2. Fill in missing constructor +-- 2. Merge nested cases -------------------------------------------------- -mkAlts scrut handled_cons case_bndr alts - | (alts_no_deflt, Just rhs) <- findDefault alts, - -- There is a DEFAULT case - - Just (tycon, inst_tys) <- splitTyConApp_maybe (idType case_bndr), - isAlgTyCon tycon, -- It's a data type, tuple, or unboxed tuples. - not (isNewTyCon tycon), -- We can have a newtype, if we are just doing an eval: - -- case x of { DEFAULT -> e } - -- and we don't want to fill in a default for them! - - Just all_cons <- tyConDataCons_maybe tycon, - [missing_con] <- [con | con <- all_cons, not (con `elem` handled_data_cons)] - -- There is just one missing constructor! - - = tick (FillInCaseDefault case_bndr) `thenSmpl_` - getUniquesSmpl `thenSmpl` \ tv_uniqs -> - getUniquesSmpl `thenSmpl` \ id_uniqs -> - let - (_,_,ex_tyvars,_,_,_) = dataConSig missing_con - ex_tyvars' = zipWith mk tv_uniqs ex_tyvars - mk uniq tv = mkSysTyVar uniq (tyVarKind tv) - arg_ids = zipWith (mkSysLocal SLIT("a")) id_uniqs arg_tys - arg_tys = dataConArgTys missing_con (inst_tys ++ mkTyVarTys ex_tyvars') - better_alts = (DataAlt missing_con, ex_tyvars' ++ arg_ids, rhs) : alts_no_deflt - in - returnSmpl better_alts - where - handled_data_cons = [data_con | DataAlt data_con <- handled_cons] - --------------------------------------------------- --- 3. Merge nested cases --------------------------------------------------- - -mkAlts scrut handled_cons outer_bndr outer_alts +mkAlts scrut outer_bndr outer_alts | opt_SimplCaseMerge, (outer_alts_without_deflt, maybe_outer_deflt) <- findDefault outer_alts, Just (Case (Var scrut_var) inner_bndr inner_alts) <- maybe_outer_deflt, @@ -958,7 +1050,7 @@ mkAlts scrut handled_cons outer_bndr outer_alts -- Catch-all -------------------------------------------------- -mkAlts scrut handled_cons case_bndr other_alts = returnSmpl other_alts +mkAlts scrut case_bndr other_alts = returnSmpl other_alts \end{code} @@ -1096,6 +1188,16 @@ I don't really know how to improve this situation. \begin{code} -------------------------------------------------- +-- 0. Check for empty alternatives +-------------------------------------------------- + +#ifdef DEBUG +mkCase1 scrut case_bndr [] + = pprTrace "mkCase1: null alts" (ppr case_bndr <+> ppr scrut) $ + returnSmpl scrut +#endif + +-------------------------------------------------- -- 1. Eliminate the case altogether if poss -------------------------------------------------- @@ -1164,7 +1266,7 @@ mkCase1 scrut case_bndr alts -- Identity case -- re_note wraps a coerce if it might be necessary re_note scrut = case head alts of - (_,_,rhs1@(Note _ _)) -> mkCoerce (exprType rhs1) (idType case_bndr) scrut + (_,_,rhs1@(Note _ _)) -> mkCoerce2 (exprType rhs1) (idType case_bndr) scrut other -> scrut