#include "HsVersions.h"
import CmdLineOpts ( switchIsOn, SimplifierSwitch(..),
- opt_SimplDoLambdaEtaExpansion, opt_SimplCaseMerge, opt_DictsStrict,
+ opt_SimplDoLambdaEtaExpansion, opt_SimplCaseMerge,
opt_UF_UpdateInPlace
)
import CoreSyn
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 )
-- 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
-- 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
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
-- 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}
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!
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
-- 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
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.
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}
-
-
projects / ghc-hetmet.git / blobdiff