X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FSimplUtils.lhs;h=983f0ecee16bbd655f03998a7aa5b24e1fd1f827;hb=438596897ebbe25a07e1c82085cfbc5bdb00f09e;hp=c72b2c43aaf21e1f855c4005df03f1a5ffe78504;hpb=63592052b4746774966913134a298ff31298ac37;p=ghc-hetmet.git diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs index c72b2c4..983f0ec 100644 --- a/ghc/compiler/simplCore/SimplUtils.lhs +++ b/ghc/compiler/simplCore/SimplUtils.lhs @@ -1,137 +1,123 @@ % -% (c) The AQUA Project, Glasgow University, 1993-1996 +% (c) The AQUA Project, Glasgow University, 1993-1998 % \section[SimplUtils]{The simplifier utilities} \begin{code} module SimplUtils ( - - newId, newIds, - - floatExposesHNF, - - etaCoreExpr, mkRhsTyLam, - - etaExpandCount, - - simplIdWantsToBeINLINEd, - - singleConstructorType, typeOkForCase + simplBinder, simplBinders, simplIds, + mkRhsTyLam, + etaCoreExpr, + etaExpandCount, + mkCase, findAlt, findDefault ) where #include "HsVersions.h" import BinderInfo -import CmdLineOpts ( opt_DoEtaReduction, SimplifierSwitch(..) ) +import CmdLineOpts ( opt_DoEtaReduction, switchIsOn, SimplifierSwitch(..) ) import CoreSyn -import CoreUnfold ( mkFormSummary, exprIsTrivial, FormSummary(..) ) -import Id ( idType, isBottomingId, mkSysLocal, - addInlinePragma, addIdDemandInfo, - idWantsToBeINLINEd, dataConArgTys, Id, - getIdArity, +import CoreUtils ( exprIsCheap, exprIsTrivial, exprFreeVars, cheapEqExpr, + FormSummary(..), + substId, substIds + ) +import Id ( Id, idType, isBottomingId, getIdArity, isId, idName, + getInlinePragma, setInlinePragma, + getIdDemandInfo ) -import IdInfo ( ArityInfo(..), DemandInfo ) +import IdInfo ( arityLowerBound, InlinePragInfo(..) ) +import Demand ( isStrict ) import Maybes ( maybeToBool ) -import PrelVals ( augmentId, buildId ) -import PrimOp ( primOpIsCheap ) -import SimplEnv +import Const ( Con(..) ) +import Name ( isLocalName ) import SimplMonad -import Type ( tyVarsOfType, mkForAllTys, mkTyVarTys, getTyVar_maybe, - splitAlgTyConApp_maybe, Type +import Type ( Type, tyVarsOfType, tyVarsOfTypes, mkForAllTys, mkTyVarTys, + splitTyConApp_maybe, mkTyVarTy, substTyVar ) -import TyCon ( isDataTyCon ) -import TyVar ( elementOfTyVarSet ) -import SrcLoc ( noSrcLoc ) -import Util ( isIn, zipWithEqual, panic, assertPanic ) - +import Var ( setVarUnique ) +import VarSet +import UniqSupply ( splitUniqSupply, uniqFromSupply ) +import Util ( zipWithEqual, mapAccumL ) +import Outputable \end{code} %************************************************************************ %* * -\subsection{New ids} +\section{Dealing with a single binder} %* * %************************************************************************ +When we hit a binder we may need to + (a) apply the the type envt (if non-empty) to its type + (b) apply the type envt and id envt to its SpecEnv (if it has one) + (c) give it a new unique to avoid name clashes + \begin{code} -newId :: Type -> SmplM Id -newId ty - = getUniqueSmpl `thenSmpl` \ uniq -> - returnSmpl (mkSysLocal SLIT("s") uniq ty noSrcLoc) - -newIds :: [Type] -> SmplM [Id] -newIds tys - = getUniquesSmpl (length tys) `thenSmpl` \ uniqs -> - returnSmpl (zipWithEqual "newIds" mk_id tys uniqs) - where - mk_id ty uniq = mkSysLocal SLIT("s") uniq ty noSrcLoc +simplBinders :: [InBinder] -> ([OutBinder] -> SimplM a) -> SimplM a +simplBinders bndrs thing_inside + = getSwitchChecker `thenSmpl` \ sw_chkr -> + getSimplBinderStuff `thenSmpl` \ stuff -> + let + must_clone = switchIsOn sw_chkr SimplPleaseClone + (stuff', bndrs') = mapAccumL (subst_binder must_clone) stuff bndrs + in + setSimplBinderStuff stuff' $ + thing_inside bndrs' + +simplBinder :: InBinder -> (OutBinder -> SimplM a) -> SimplM a +simplBinder bndr thing_inside + = getSwitchChecker `thenSmpl` \ sw_chkr -> + getSimplBinderStuff `thenSmpl` \ stuff -> + let + must_clone = switchIsOn sw_chkr SimplPleaseClone + (stuff', bndr') = subst_binder must_clone stuff bndr + in + setSimplBinderStuff stuff' $ + thing_inside bndr' + +-- Same semantics as simplBinders, but a little less +-- plumbing and hence a little more efficient. +-- Maybe not worth the candle? +simplIds :: [InBinder] -> ([OutBinder] -> SimplM a) -> SimplM a +simplIds ids thing_inside + = getSwitchChecker `thenSmpl` \ sw_chkr -> + getSimplBinderStuff `thenSmpl` \ (ty_subst, id_subst, in_scope, us) -> + let + must_clone = switchIsOn sw_chkr SimplPleaseClone + (id_subst', in_scope', us', ids') = substIds (simpl_clone_fn must_clone) + ty_subst id_subst in_scope us ids + in + setSimplBinderStuff (ty_subst, id_subst', in_scope', us') $ + thing_inside ids' + +subst_binder must_clone (ty_subst, id_subst, in_scope, us) bndr + | isTyVar bndr + = case substTyVar ty_subst in_scope bndr of + (ty_subst', in_scope', bndr') -> ((ty_subst', id_subst, in_scope', us), bndr') + + | otherwise + = case substId (simpl_clone_fn must_clone) ty_subst id_subst in_scope us bndr of + (id_subst', in_scope', us', bndr') + -> ((ty_subst, id_subst', in_scope', us'), bndr') + +simpl_clone_fn must_clone in_scope us id + | (must_clone && isLocalName (idName id)) + || id `elemVarSet` in_scope + = case splitUniqSupply us of + (us1, us2) -> Just (us1, setVarUnique id (uniqFromSupply us2)) + + | otherwise + = Nothing \end{code} %************************************************************************ %* * -\subsection{Floating} +\subsection{Local tyvar-lifting} %* * %************************************************************************ -The function @floatExposesHNF@ tells whether let/case floating will -expose a head normal form. It is passed booleans indicating the -desired strategy. - -\begin{code} -floatExposesHNF - :: Bool -- Float let(rec)s out of rhs - -> Bool -- Float cheap primops out of rhs - -> Bool -- OK to duplicate code - -> GenCoreExpr bdr Id flexi - -> Bool - -floatExposesHNF float_lets float_primops ok_to_dup rhs - = try rhs - where - try (Case (Prim _ _) (PrimAlts alts deflt) ) - | float_primops && (null alts || ok_to_dup) - = or (try_deflt deflt : map try_alt alts) - - try (Let bind body) | float_lets = try body - - -- `build g' - -- is like a HNF, - -- because it *will* become one. - -- likewise for `augment g h' - -- - try (App (App (Var bld) _) _) | bld == buildId = True - try (App (App (App (Var aug) _) _) _) | aug == augmentId = True - - try other = case mkFormSummary other of - VarForm -> True - ValueForm -> True - other -> False - {- but *not* necessarily "BottomForm"... - - We may want to float a let out of a let to expose WHNFs, - but to do that to expose a "bottom" is a Bad Idea: - let x = let y = ... - in ...error ...y... -- manifestly bottom using y - in ... - =/=> - let y = ... - in let x = ...error ...y... - in ... - - as y is only used in case of an error, we do not want - to allocate it eagerly as that's a waste. - -} - - try_alt (lit,rhs) = try rhs - - try_deflt NoDefault = False - try_deflt (BindDefault _ rhs) = try rhs -\end{code} - - -Local tyvar-lifting -~~~~~~~~~~~~~~~~~~~ mkRhsTyLam tries this transformation, when the big lambda appears as the RHS of a let(rec) binding: @@ -147,7 +133,7 @@ This is good because it can turn things like: into letrec g' = /\a -> ... g' a ... in - let f = /\ a -> f a + let f = /\ a -> g' a which is better. In effect, it means that big lambdas don't impede let-floating. @@ -175,38 +161,88 @@ So far as the implemtation is concerned: G = F . Let {xi = xi' tvs} \begin{code} -mkRhsTyLam [] body = returnSmpl body +mkRhsTyLam (Lam b e) + | isTyVar b = case collectTyBinders e of + (bs,body) -> mkRhsTyLam_help (b:bs) body + +mkRhsTyLam other_expr -- No-op if not a type lambda + = returnSmpl other_expr -mkRhsTyLam tyvars body + +mkRhsTyLam_help tyvars body = go (\x -> x) body where - tyvar_tys = mkTyVarTys tyvars + main_tyvar_set = mkVarSet tyvars go fn (Let bind@(NonRec var rhs) body) | exprIsTrivial rhs = go (fn . Let bind) body go fn (Let bind@(NonRec var rhs) body) - = mk_poly var `thenSmpl` \ (var', rhs') -> + = mk_poly tyvars_here var `thenSmpl` \ (var', rhs') -> go (fn . Let (mk_silly_bind var rhs')) body `thenSmpl` \ body' -> - returnSmpl (Let (NonRec var' (mkTyLam tyvars (fn rhs))) body') + returnSmpl (Let (NonRec var' (mkLams tyvars_here (fn rhs))) body') + where + tyvars_here = tyvars + -- varSetElems (main_tyvar_set `intersectVarSet` tyVarsOfType var_ty) + -- tyvars_here was an attempt to reduce the number of tyvars + -- wrt which the new binding is abstracted. But the naive + -- approach of abstract wrt the tyvars free in the Id's type + -- fails. Consider: + -- /\ a b -> let t :: (a,b) = (e1, e2) + -- x :: a = fst t + -- in ... + -- Here, b isn't free in a's type, but we must nevertheless + -- abstract wrt b as well, because t's type mentions b. + -- Since t is floated too, we'd end up with the bogus: + -- poly_t = /\ a b -> (e1, e2) + -- poly_x = /\ a -> fst (poly_t a *b*) + -- So for now we adopt the even more naive approach of + -- abstracting wrt *all* the tyvars. We'll see if that + -- gives rise to problems. SLPJ June 98 + + var_ty = idType var go fn (Let (Rec prs) body) - = mapAndUnzipSmpl mk_poly vars `thenSmpl` \ (vars', rhss') -> + = mapAndUnzipSmpl (mk_poly tyvars_here) vars `thenSmpl` \ (vars', rhss') -> let gn body = fn $ foldr Let body (zipWith mk_silly_bind vars rhss') in go gn body `thenSmpl` \ body' -> - returnSmpl (Let (Rec (vars' `zip` [mkTyLam tyvars (gn rhs) | rhs <- rhss])) body') + returnSmpl (Let (Rec (vars' `zip` [mkLams tyvars_here (gn rhs) | rhs <- rhss])) body') where (vars,rhss) = unzip prs + tyvars_here = tyvars + -- varSetElems (main_tyvar_set `intersectVarSet` tyVarsOfTypes var_tys) + -- See notes with tyvars_here above + + var_tys = map idType vars + + go fn body = returnSmpl (mkLams tyvars (fn body)) + + mk_poly tyvars_here var + = newId (mkForAllTys tyvars_here (idType var)) $ \ poly_id -> + let + -- It's crucial to copy the inline-prag of the original var, because + -- we're looking at occurrence-analysed but as yet unsimplified code! + -- In particular, we mustn't lose the loop breakers. + -- + -- *However* we don't want to retain a single-occurrence or dead-var info + -- because we're adding a load of "silly bindings" of the form + -- var _U_ = poly_var t1 t2 + -- with a must-inline pragma on the silly binding to prevent the + -- poly-var from being inlined right back in. Since poly_var now + -- occurs inside an INLINE binding, it should be given a ManyOcc, + -- else it may get inlined unconditionally + poly_inline_prag = case getInlinePragma var of + ICanSafelyBeINLINEd _ _ -> NoInlinePragInfo + IAmDead -> NoInlinePragInfo + var_inline_prag -> var_inline_prag + + poly_id' = setInlinePragma poly_id poly_inline_prag + in + returnSmpl (poly_id', mkTyApps (Var poly_id') (mkTyVarTys tyvars_here)) - go fn body = returnSmpl (mkTyLam tyvars (fn body)) - - mk_poly var - = newId (mkForAllTys tyvars (idType var)) `thenSmpl` \ poly_id -> - returnSmpl (poly_id, mkTyApp (Var poly_id) tyvar_tys) - - mk_silly_bind var rhs = NonRec (addInlinePragma var) rhs + mk_silly_bind var rhs = NonRec (setInlinePragma var IWantToBeINLINEd) rhs -- The addInlinePragma is really important! If we don't say -- INLINE on these silly little bindings then look what happens! -- Suppose we start with: @@ -221,10 +257,19 @@ mkRhsTyLam tyvars body -- * so we're back to square one -- The silly binding for g* must be INLINE, so that no inlining -- will happen in its RHS. + -- PS: Jun 98: actually this isn't important any more; + -- inlineUnconditionally will catch the type applicn + -- and inline it unconditionally, without ever trying + -- to simplify the RHS \end{code} -Eta reduction -~~~~~~~~~~~~~ + +%************************************************************************ +%* * +\subsection{Eta reduction} +%* * +%************************************************************************ + @etaCoreExpr@ trys an eta reduction at the top level of a Core Expr. e.g. \ x y -> f x y ===> f @@ -234,98 +279,53 @@ It is used try to make the unfolding smaller; b) In tidyCoreExpr, which is done just before converting to STG. -But we only do this if it gets rid of a whole lambda, not part. -The idea is that lambdas are often quite helpful: they indicate -head normal forms, so we don't want to chuck them away lightly. -But if they expose a simple variable then we definitely win. Even -if they expose a type application we win. So we check for this special -case. - -It does arise: - - f xs = [y | (y,_) <- xs] - -gives rise to a recursive function for the list comprehension, and -f turns out to be just a single call to this recursive function. - -Doing eta on type lambdas is useful too: - - /\a -> a ===> - -where doesn't mention a. -This is sometimes quite useful, because we can get the sequence: - - f ab d = let d1 = ...d... in - letrec f' b x = ...d...(f' b)... in - f' b -specialise ==> +But we only do this if + i) It gets rid of a whole lambda, not part. + The idea is that lambdas are often quite helpful: they indicate + head normal forms, so we don't want to chuck them away lightly. - f.Int b = letrec f' b x = ...dInt...(f' b)... in - f' b - -float ==> - - f' b x = ...dInt...(f' b)... - f.Int b = f' b - -Now we really want to simplify to - - f.Int = f' - -and then replace all the f's with f.Ints. - -N.B. We are careful not to partially eta-reduce a sequence of type -applications since this breaks the specialiser: - - /\ a -> f Char# a =NO=> f Char# + ii) It exposes a simple variable or a type application; in short + it exposes a "trivial" expression. (exprIsTrivial) \begin{code} etaCoreExpr :: CoreExpr -> CoreExpr - + -- ToDo: we should really check that we don't turn a non-bottom + -- lambda into a bottom variable. Sigh etaCoreExpr expr@(Lam bndr body) | opt_DoEtaReduction - = case etaCoreExpr body of - App fun arg | eta_match bndr arg && - residual_ok fun - -> fun -- Eta - other -> expr -- Can't eliminate it, so do nothing at all + = check (reverse binders) body where - eta_match (ValBinder v) (VarArg v') = v == v' - eta_match (TyBinder tv) (TyArg ty) = case getTyVar_maybe ty of - Nothing -> False - Just tv' -> tv == tv' - eta_match bndr arg = False - - residual_ok :: CoreExpr -> Bool -- Checks for type application - -- and function not one of the - -- bound vars - - (VarArg v) `mentions` (ValBinder v') = v == v' - (TyArg ty) `mentions` (TyBinder tv) = tv `elementOfTyVarSet` tyVarsOfType ty - bndr `mentions` arg = False - - residual_ok (Var v) - = not (VarArg v `mentions` bndr) - residual_ok (App fun arg) - | arg `mentions` bndr = False - | otherwise = residual_ok fun - residual_ok (Coerce coercion ty body) - | TyArg ty `mentions` bndr = False - | otherwise = residual_ok body - - residual_ok other = False -- Safe answer - -- This last clause may seem conservative, but consider: - -- primops, constructors, and literals, are impossible here - -- let and case are unlikely (the argument would have been floated inside) - -- SCCs we probably want to be conservative about (not sure, but it's safe to be) + (binders, body) = collectBinders expr + + check [] body + | exprIsTrivial body && not (any (`elemVarSet` body_fvs) binders) + = body -- Success! + where + body_fvs = exprFreeVars body + + check (b : bs) (App fun arg) + | (varToCoreExpr b `cheapEqExpr` arg) + && not (is_strict_binder b) + = check bs fun + + check _ _ = expr -- Bale out + + -- We don't want to eta-abstract (\x -> f x) if x carries a "strict" + -- demand info. That demand info conveys useful information to the + -- call site, via the let-to-case transform, so we don't want to discard it. + is_strict_binder b = isId b && isStrict (getIdDemandInfo b) etaCoreExpr expr = expr -- The common case \end{code} -Eta expansion -~~~~~~~~~~~~~ +%************************************************************************ +%* * +\subsection{Eta expansion} +%* * +%************************************************************************ + @etaExpandCount@ takes an expression, E, and returns an integer n, such that @@ -343,26 +343,29 @@ arguments as you care to give it. For this special case we return 100, to represent "infinity", which is a bit of a hack. \begin{code} -etaExpandCount :: GenCoreExpr bdr Id flexi +etaExpandCount :: CoreExpr -> Int -- Number of extra args you can safely abstract -etaExpandCount (Lam (ValBinder _) body) +etaExpandCount (Lam b body) + | isId b = 1 + etaExpandCount body etaExpandCount (Let bind body) - | all manifestlyCheap (rhssOfBind bind) + | all exprIsCheap (rhssOfBind bind) = etaExpandCount body -etaExpandCount (Case scrut alts) - | manifestlyCheap scrut - = minimum [etaExpandCount rhs | rhs <- rhssOfAlts alts] +etaExpandCount (Case scrut _ alts) + | exprIsCheap scrut + = minimum [etaExpandCount rhs | (_,_,rhs) <- alts] etaExpandCount fun@(Var _) = eta_fun fun + +etaExpandCount (App fun (Type ty)) + = eta_fun fun etaExpandCount (App fun arg) - | notValArg arg = eta_fun fun - | otherwise = case etaExpandCount fun of - 0 -> 0 - n -> n-1 -- Knock off one + | exprIsCheap arg = case etaExpandCount fun of + 0 -> 0 + n -> n-1 -- Knock off one etaExpandCount other = 0 -- Give up -- Lit, Con, Prim, @@ -372,126 +375,134 @@ etaExpandCount other = 0 -- Give up -- Case with non-whnf scrutinee ----------------------------- -eta_fun :: GenCoreExpr bdr Id flexi -- The function - -> Int -- How many args it can safely be applied to +eta_fun :: CoreExpr -- The function + -> Int -- How many args it can safely be applied to -eta_fun (App fun arg) | notValArg arg = eta_fun fun +eta_fun (App fun (Type ty)) = eta_fun fun -eta_fun expr@(Var v) +eta_fun (Var v) | isBottomingId v -- Bottoming ids have "infinite arity" = 10000 -- Blargh. Infinite enough! -eta_fun expr@(Var v) = idMinArity v +eta_fun (Var v) = arityLowerBound (getIdArity v) eta_fun other = 0 -- Give up \end{code} -@manifestlyCheap@ looks at a Core expression and returns \tr{True} if -it is obviously in weak head normal form, or is cheap to get to WHNF. -By ``cheap'' we mean a computation we're willing to duplicate in order -to bring a couple of lambdas together. The main examples of things -which aren't WHNF but are ``cheap'' are: - * case e of - pi -> ei +%************************************************************************ +%* * +\subsection{Case absorption and identity-case elimination} +%* * +%************************************************************************ - where e, and all the ei are cheap; and +\begin{code} +mkCase :: SwitchChecker -> OutExpr -> OutId -> [OutAlt] -> SimplM OutExpr +\end{code} - * let x = e - in b +@mkCase@ tries the following transformation (if possible): + +case e of b { ==> case e of b { + p1 -> rhs1 p1 -> rhs1 + ... ... + pm -> rhsm pm -> rhsm + _ -> case b of b' { pn -> rhsn[b/b'] {or (alg) let b=b' in rhsn} + {or (prim) case b of b' { _ -> rhsn}} + pn -> rhsn ... + ... po -> rhso[b/b'] + po -> rhso _ -> rhsd[b/b'] {or let b'=b in rhsd} + _ -> rhsd +} + +which merges two cases in one case when -- the default alternative of +the outer case scrutises the same variable as the outer case This +transformation is called Case Merging. It avoids that the same +variable is scrutinised multiple times. - where e and b are cheap; and +\begin{code} +mkCase sw_chkr scrut outer_bndr outer_alts + | switchIsOn sw_chkr SimplCaseMerge + && maybeToBool maybe_case_in_default + + = tick CaseMerge `thenSmpl_` + returnSmpl (Case scrut outer_bndr new_alts) + -- Warning: don't call mkCase recursively! + -- Firstly, there's no point, because inner alts have already had + -- 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 bindNonRec + -- in munge_rhs puts a case into the DEFAULT branch! + where + new_alts = outer_alts_without_deflt ++ munged_inner_alts + maybe_case_in_default = case findDefault outer_alts of + (outer_alts_without_default, + Just (Case (Var scrut_var) inner_bndr inner_alts)) + + | outer_bndr == scrut_var + -> Just (outer_alts_without_default, inner_bndr, inner_alts) + other -> Nothing + + Just (outer_alts_without_deflt, inner_bndr, inner_alts) = maybe_case_in_default + + -- Eliminate any inner alts which are shadowed by the outer ones + outer_cons = [con | (con,_,_) <- outer_alts_without_deflt] + + munged_inner_alts = [ (con, args, munge_rhs rhs) + | (con, args, rhs) <- inner_alts, + not (con `elem` outer_cons) -- Eliminate shadowed inner alts + ] + munge_rhs rhs = bindNonRec inner_bndr (Var outer_bndr) rhs +\end{code} - * op x1 ... xn +Now the identity-case transformation: - where op is a cheap primitive operator + case e of ===> e + True -> True; + False -> False -\begin{code} -manifestlyCheap :: GenCoreExpr bndr Id flexi -> Bool - -manifestlyCheap (Var _) = True -manifestlyCheap (Lit _) = True -manifestlyCheap (Con _ _) = True -manifestlyCheap (SCC _ e) = manifestlyCheap e -manifestlyCheap (Coerce _ _ e) = manifestlyCheap e -manifestlyCheap (Lam x e) = if isValBinder x then True else manifestlyCheap e -manifestlyCheap (Prim op _) = primOpIsCheap op - -manifestlyCheap (Let bind body) - = manifestlyCheap body && all manifestlyCheap (rhssOfBind bind) - -manifestlyCheap (Case scrut alts) - = manifestlyCheap scrut && all manifestlyCheap (rhssOfAlts alts) - -manifestlyCheap other_expr -- look for manifest partial application - = case (collectArgs other_expr) of { (fun, _, vargs) -> - case fun of - - Var f | isBottomingId f -> True -- Application of a function which - -- always gives bottom; we treat this as - -- a WHNF, because it certainly doesn't - -- need to be shared! - - Var f -> let - num_val_args = length vargs - in - num_val_args == 0 || -- Just a type application of - -- a variable (f t1 t2 t3) - -- counts as WHNF - num_val_args < idMinArity f - - _ -> False - } +and similar friends. +\begin{code} +mkCase sw_chkr scrut case_bndr alts + | all identity_alt alts + = tick CaseIdentity `thenSmpl_` + returnSmpl scrut + where + identity_alt (DEFAULT, [], Var v) = v == case_bndr + identity_alt (con, args, Con con' args') = con == con' && + and (zipWithEqual "mkCase" + cheapEqExpr + (map Type arg_tys ++ map varToCoreExpr args) + args') + identity_alt other = False + + arg_tys = case splitTyConApp_maybe (idType case_bndr) of + Just (tycon, arg_tys) -> arg_tys \end{code} +The catch-all case \begin{code} -simplIdWantsToBeINLINEd :: Id -> SimplEnv -> Bool +mkCase sw_chkr other_scrut case_bndr other_alts + = returnSmpl (Case other_scrut case_bndr other_alts) +\end{code} -simplIdWantsToBeINLINEd id env - = {- We used to arrange that in the final simplification pass we'd switch - off all INLINE pragmas, so that we'd inline workers back into the - body of their wrapper if the wrapper hadn't itself been inlined by then. - This occurred especially for methods in dictionaries. - We no longer do this: - a) there's a good chance that the exported wrapper will get - inlined in some importing scope, in which case we don't - want to lose the w/w idea. +\begin{code} +findDefault :: [CoreAlt] -> ([CoreAlt], Maybe CoreExpr) +findDefault [] = ([], Nothing) +findDefault ((DEFAULT,args,rhs) : alts) = ASSERT( null alts && null args ) + ([], Just rhs) +findDefault (alt : alts) = case findDefault alts of + (alts', deflt) -> (alt : alts', deflt) + +findAlt :: Con -> [CoreAlt] -> CoreAlt +findAlt con alts + = go alts + where + go [] = pprPanic "Missing alternative" (ppr con $$ vcat (map ppr alts)) + go (alt : alts) | matches alt = alt + | otherwise = go alts - b) The occurrence analyser must agree about what has an - INLINE pragma. Not hard, but delicate. - - c) if the worker gets inlined we have to tell the wrapepr - that it's no longer a wrapper, else the interface file stuff - asks for a worker that no longer exists. - - if switchIsSet env IgnoreINLINEPragma - then False - else - -} - - idWantsToBeINLINEd id - -idMinArity id = case getIdArity id of - UnknownArity -> 0 - ArityAtLeast n -> n - ArityExactly n -> n - -singleConstructorType :: Type -> Bool -singleConstructorType ty - = case (splitAlgTyConApp_maybe ty) of - Just (tycon, ty_args, [con]) | isDataTyCon tycon -> True - other -> False - -typeOkForCase :: Type -> Bool -typeOkForCase ty - = case (splitAlgTyConApp_maybe ty) of - Just (tycon, ty_args, []) -> False - Just (tycon, ty_args, non_null_data_cons) | isDataTyCon tycon -> True - other -> False - -- Null data cons => type is abstract, which code gen can't - -- currently handle. (ToDo: when return-in-heap is universal we - -- don't need to worry about this.) + matches (DEFAULT, _, _) = True + matches (con1, _, _) = con == con1 \end{code}