X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FSimplUtils.lhs;h=31f63151b08b3027e093ce271b2d2be6303db241;hb=d6b7d200353e0bcc5a19a43caf252f37dee5bc6c;hp=817ae8fc1bdbdc9032f6814e68d0378bc899f1b1;hpb=5f087cf4add4e140e7df05d896ee6b271133f822;p=ghc-hetmet.git diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs index 817ae8f..31f6315 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 TyCon ( tyConDataConsIfAvailable, isAlgTyCon, isNewTyCon ) -import DataCon ( dataConRepArity, dataConSig, dataConArgTys ) +import OccName ( EncodedFS ) +import TyCon ( tyConDataCons_maybe, isAlgTyCon, isNewTyCon ) +import DataCon ( dataConRepArity, dataConExistentialTyVars, dataConArgTys ) import Var ( mkSysTyVar, tyVarKind ) +import VarSet import Util ( lengthExceeds, mapAccumL ) import Outputable \end{code} @@ -232,14 +234,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 +275,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 @@ -405,10 +410,10 @@ canUpdateInPlace ty | otherwise = case splitTyConApp_maybe ty of Nothing -> False - Just (tycon, _) -> case tyConDataConsIfAvailable tycon of - [dc] -> arity == 1 || arity == 2 - where - arity = dataConRepArity dc + Just (tycon, _) -> case tyConDataCons_maybe tycon of + Just [dc] -> arity == 1 || arity == 2 + where + arity = dataConRepArity dc other -> False \end{code} @@ -471,7 +476,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 +545,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 +783,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 +919,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 +945,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 +988,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 +1000,10 @@ mkAlts scrut handled_cons case_bndr alts@((con1,bndrs1,rhs1) : con_alts) -------------------------------------------------- --- 2. Fill in missing constructor --------------------------------------------------- - -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! - - [missing_con] <- [con | con <- tyConDataConsIfAvailable tycon, - 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 +-- 2. 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 +1047,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 +1185,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 +1263,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