\begin{code}
module SimplUtils (
- simplBinder, simplBinders, simplIds,
+ simplBinder, simplBinders, simplRecIds, simplLetId,
tryRhsTyLam, tryEtaExpansion,
- mkCase, findAlt, findDefault,
+ mkCase,
-- The continuation type
SimplCont(..), DupFlag(..), contIsDupable, contResultType,
#include "HsVersions.h"
import CmdLineOpts ( switchIsOn, SimplifierSwitch(..),
- opt_SimplDoLambdaEtaExpansion, opt_SimplCaseMerge, opt_DictsStrict,
+ opt_SimplDoLambdaEtaExpansion, opt_SimplCaseMerge,
opt_UF_UpdateInPlace
)
import CoreSyn
-import CoreUtils ( exprIsTrivial, cheapEqExpr, exprType, exprIsCheap, etaExpand, exprEtaExpandArity, bindNonRec )
-import Subst ( InScopeSet, mkSubst, substBndrs, substBndr, substIds, substExpr )
+import CoreUtils ( exprIsTrivial, cheapEqExpr, exprType, exprIsCheap,
+ etaExpand, exprEtaExpandArity, bindNonRec, mkCoerce,
+ findDefault
+ )
+import Subst ( InScopeSet, mkSubst, substExpr )
+import qualified Subst ( simplBndrs, simplBndr, simplLetId )
import Id ( idType, idName,
idUnfolding, idStrictness,
- mkVanillaId, idInfo
+ mkLocalId, idInfo
)
import IdInfo ( StrictnessInfo(..) )
import Maybes ( maybeToBool, catMaybes )
import Name ( setNameUnique )
import Demand ( isStrict )
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 )
-import Util ( lengthExceeds )
+import Util ( lengthExceeds, mapAccumL )
import Outputable
\end{code}
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}
simplBinders bndrs thing_inside
= getSubst `thenSmpl` \ subst ->
let
- (subst', bndrs') = substBndrs subst bndrs
+ (subst', bndrs') = Subst.simplBndrs subst bndrs
in
seqBndrs bndrs' `seq`
setSubst subst' (thing_inside bndrs')
simplBinder bndr thing_inside
= getSubst `thenSmpl` \ subst ->
let
- (subst', bndr') = substBndr subst bndr
+ (subst', bndr') = Subst.simplBndr subst bndr
in
seqBndr bndr' `seq`
setSubst subst' (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
+simplRecIds :: [InBinder] -> ([OutBinder] -> SimplM a) -> SimplM a
+simplRecIds ids thing_inside
= getSubst `thenSmpl` \ subst ->
let
- (subst', bndrs') = substIds subst ids
+ (subst', ids') = mapAccumL Subst.simplLetId subst ids
in
- seqBndrs bndrs' `seq`
- setSubst subst' (thing_inside bndrs')
+ seqBndrs ids' `seq`
+ setSubst subst' (thing_inside ids')
+
+simplLetId :: InBinder -> (OutBinder -> SimplM a) -> SimplM a
+simplLetId id thing_inside
+ = getSubst `thenSmpl` \ subst ->
+ let
+ (subst', id') = Subst.simplLetId subst id
+ in
+ seqBndr id' `seq`
+ setSubst subst' (thing_inside id')
seqBndrs [] = ()
seqBndrs (b:bs) = seqBndr b `seq` seqBndrs bs
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.
mkCase scrut case_bndr alts
| all identity_alt alts
= tick (CaseIdentity case_bndr) `thenSmpl_`
- returnSmpl scrut
+ returnSmpl (re_note scrut)
where
- identity_alt (DEFAULT, [], Var v) = v == case_bndr
- identity_alt (DataAlt con, args, rhs) = cheapEqExpr rhs
- (mkConApp con (map Type arg_tys ++ map varToCoreExpr args))
- identity_alt other = False
-
- arg_tys = tyConAppArgs (idType case_bndr)
+ identity_alt (con, args, rhs) = de_note rhs `cheapEqExpr` identity_rhs con args
+
+ identity_rhs (DataAlt con) args = mkConApp con (arg_tys ++ map varToCoreExpr args)
+ identity_rhs (LitAlt lit) _ = Lit lit
+ identity_rhs DEFAULT _ = Var case_bndr
+
+ arg_tys = map Type (tyConAppArgs (idType case_bndr))
+
+ -- We've seen this:
+ -- case coerce T e of x { _ -> coerce T' x }
+ -- And we definitely want to eliminate this case!
+ -- So we throw away notes from the RHS, and reconstruct
+ -- (at least an approximation) at the other end
+ de_note (Note _ e) = de_note e
+ de_note e = e
+
+ -- 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
+ 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:
-\begin{code}
-mkCase other_scrut case_bndr other_alts
- = returnSmpl (Case other_scrut case_bndr other_alts)
-\end{code}
+ 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):
-\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 :: AltCon -> [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
+ x | p `is` 1 -> e1
+ | p `is` 2 -> e2
+ ...etc...
- matches (DEFAULT, _, _) = True
- matches (con1, _, _) = con == con1
+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 (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