X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Fcompiler%2FsimplCore%2FSimplUtils.lhs;h=836d2ab6b550a14dd4f61cd207fedd2f4990cdbf;hb=b17957ce78ec9ac16db7bba2b20b29548d5ca1db;hp=c4f528e182196c307370cef3189d54c028e52c81;hpb=09518039f8f793e6464c1703506089a107926d11;p=ghc-hetmet.git diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs index c4f528e..836d2ab 100644 --- a/ghc/compiler/simplCore/SimplUtils.lhs +++ b/ghc/compiler/simplCore/SimplUtils.lhs @@ -19,7 +19,7 @@ module SimplUtils ( #include "HsVersions.h" import CmdLineOpts ( switchIsOn, SimplifierSwitch(..), - opt_SimplDoLambdaEtaExpansion, opt_SimplCaseMerge, opt_DictsStrict, + opt_SimplDoLambdaEtaExpansion, opt_SimplCaseMerge, opt_UF_UpdateInPlace ) import CoreSyn @@ -30,19 +30,20 @@ import CoreUtils ( exprIsTrivial, cheapEqExpr, exprType, exprIsCheap, import Subst ( InScopeSet, mkSubst, substExpr ) import qualified Subst ( simplBndrs, simplBndr, simplLetId ) import Id ( idType, idName, - idUnfolding, idStrictness, - mkVanillaId, idInfo + idUnfolding, idNewStrictness, + mkLocalId, idInfo ) import IdInfo ( StrictnessInfo(..) ) import Maybes ( maybeToBool, catMaybes ) import Name ( setNameUnique ) -import Demand ( isStrict ) +import NewDemand ( isStrictDmd, isBotRes, splitStrictSig ) import SimplMonad -import Type ( Type, mkForAllTys, seqType, repType, +import Type ( Type, mkForAllTys, seqType, splitTyConApp_maybe, tyConAppArgs, mkTyVarTys, - isDictTy, isDataType, isUnLiftedType, + isUnLiftedType, splitRepFunTys ) +import TcType ( isStrictType ) import TyCon ( tyConDataConsIfAvailable ) import DataCon ( dataConRepArity ) import VarEnv ( SubstEnv ) @@ -229,8 +230,8 @@ getContArgs fun orig_cont -- after that number of value args have been consumed -- Otherwise it's infinite, extended with False fun_stricts - = case idStrictness fun of - StrictnessInfo demands result_bot + = case splitStrictSig (idNewStrictness fun) of + (demands, result_info) | not (demands `lengthExceeds` countValArgs orig_cont) -> -- Enough args, use the strictness given. -- For bottoming functions we used to pretend that the arg @@ -239,26 +240,13 @@ getContArgs fun orig_cont -- top-level bindings for (say) strings into -- calls to error. But now we are more careful about -- inlining lone variables, so its ok (see SimplUtils.analyseCont) - if result_bot then - map isStrict demands -- Finite => result is bottom + if isBotRes result_info then + map isStrictDmd demands -- Finite => result is bottom else - map isStrict demands ++ vanilla_stricts + map isStrictDmd demands ++ vanilla_stricts other -> vanilla_stricts -- Not enough args, or no strictness - -------------------- -isStrictType :: Type -> Bool - -- isStrictType computes whether an argument (or let RHS) should - -- be computed strictly or lazily, based only on its type -isStrictType ty - | isUnLiftedType ty = True - | opt_DictsStrict && isDictTy ty && isDataType ty = True - | otherwise = False - -- Return true only for dictionary types where the dictionary - -- has more than one component (else we risk poking on the component - -- of a newtype dictionary) - ------------------- interestingArg :: InScopeSet -> InExpr -> SubstEnv -> Bool -- An argument is interesting if it has *some* structure @@ -369,7 +357,10 @@ interestingCallContext some_args some_val_args cont where interesting (InlinePlease _) = True interesting (Select _ _ _ _ _) = some_args - interesting (ApplyTo _ _ _ _) = some_args -- Can happen if we have (coerce t (f x)) y + interesting (ApplyTo _ _ _ _) = True -- 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 (ArgOf _ _ _) = some_val_args interesting (Stop ty upd_in_place) = some_val_args && upd_in_place interesting (CoerceIt _ cont) = interesting cont @@ -399,21 +390,16 @@ canUpdateInPlace :: Type -> Bool -- small arity. But arity zero isn't good -- we share the single copy -- for that case, so no point in sharing. --- Note the repType: we want to look through newtypes for this purpose - canUpdateInPlace ty | not opt_UF_UpdateInPlace = False | otherwise - = case splitTyConApp_maybe (repType ty) of { - Nothing -> False ; - Just (tycon, _) -> - - case tyConDataConsIfAvailable tycon of - [dc] -> arity == 1 || arity == 2 - where - arity = dataConRepArity dc - other -> False - } + = case splitTyConApp_maybe ty of + Nothing -> False + Just (tycon, _) -> case tyConDataConsIfAvailable tycon of + [dc] -> arity == 1 || arity == 2 + where + arity = dataConRepArity dc + other -> False \end{code} @@ -615,7 +601,7 @@ tryRhsTyLam rhs -- Only does something if there's a let let poly_name = setNameUnique (idName var) uniq -- Keep same name poly_ty = mkForAllTys tyvars_here (idType var) -- But new type of course - poly_id = mkVanillaId poly_name poly_ty + poly_id = mkLocalId poly_name poly_ty -- In the olden days, it was crucial to copy the occInfo of the original var, -- because we were looking at occurrence-analysed but as yet unsimplified code! @@ -687,6 +673,11 @@ There is no point in looking for a combination of the two, because that would leave use with some lets sandwiched between lambdas; that's what the final test in the first equation is for. +In Case 1, we may have to sandwich some coerces between the lambdas +to make the types work. exprEtaExpandArity looks through coerces +when computing arity; and etaExpand adds the coerces as necessary when +actually computing the expansion. + \begin{code} tryEtaExpansion :: OutExpr -> OutType -> SimplM ([OutBind], OutExpr) tryEtaExpansion rhs rhs_ty @@ -766,11 +757,12 @@ mkCase scrut outer_bndr outer_alts -- 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 + new_alts = add_default maybe_inner_default + (outer_alts_without_deflt ++ inner_con_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 @@ -785,12 +777,17 @@ mkCase scrut outer_bndr outer_alts not (con `elem` outer_cons) -- Eliminate shadowed inner alts ] munge_rhs rhs = bindNonRec inner_bndr (Var outer_bndr) rhs + + (inner_con_alts, maybe_inner_default) = findDefault munged_inner_alts + + add_default (Just rhs) alts = (DEFAULT,[],rhs) : alts + add_default Nothing alts = alts \end{code} Now the identity-case transformation: case e of ===> e - True -> True; + True -> True; False -> False and similar friends. @@ -823,11 +820,43 @@ mkCase scrut case_bndr alts other -> scrut \end{code} -The catch-all case +The catch-all case. We do a final transformation that I've +occasionally seen making a big difference: + + case e of =====> case e of + C _ -> f x D v -> ....v.... + D v -> ....v.... DEFAULT -> f x + DEFAULT -> f x +The point is that we merge common RHSs, at least for the DEFAULT case. +[One could do something more elaborate but I've never seen it needed.] +The case where this came up was like this (lib/std/PrelCError.lhs): + + x | p `is` 1 -> e1 + | p `is` 2 -> e2 + ...etc... + +where @is@ was something like + + p `is` n = p /= (-1) && p == n + +This gave rise to a horrible sequence of cases + + case p of + (-1) -> $j p + 1 -> e1 + DEFAULT -> $j p + +and similarly in cascade for all the join points! + \begin{code} mkCase other_scrut case_bndr other_alts - = returnSmpl (Case other_scrut case_bndr other_alts) + = returnSmpl (Case other_scrut case_bndr (mergeDefault other_alts)) + +mergeDefault (deflt_alt@(DEFAULT,_,deflt_rhs) : con_alts) + = deflt_alt : [alt | alt@(con,_,rhs) <- con_alts, not (rhs `cheapEqExpr` deflt_rhs)] + -- NB: we can neglect the binders because we won't get equality if the + -- binders are mentioned in rhs (no shadowing) +mergeDefault other_alts + = other_alts \end{code} - -