mkPiType,
-- Taking expressions apart
- findDefault, findAlt,
+ findDefault, findAlt, hasDefault,
-- Properties of expressions
exprType, coreAltsType,
import Demand ( appIsBottom )
import Type ( Type, mkFunTy, mkForAllTy, splitFunTy_maybe,
applyTys, isUnLiftedType, seqType, mkUTy, mkTyVarTy,
- splitForAllTy_maybe, splitNewType_maybe, isForAllTy
+ splitForAllTy_maybe, isForAllTy, eqType
)
import TysWiredIn ( boolTy, trueDataCon, falseDataCon )
import CostCentre ( CostCentre )
mkCoerce :: Type -> Type -> CoreExpr -> CoreExpr
mkCoerce to_ty from_ty (Note (Coerce to_ty2 from_ty2) expr)
- = ASSERT( from_ty == to_ty2 )
+ = ASSERT( from_ty `eqType` to_ty2 )
mkCoerce to_ty from_ty2 expr
mkCoerce to_ty from_ty expr
- | to_ty == from_ty = expr
- | otherwise = ASSERT( from_ty == exprType expr )
- Note (Coerce to_ty from_ty) expr
+ | to_ty `eqType` from_ty = expr
+ | otherwise = ASSERT( from_ty `eqType` exprType expr )
+ Note (Coerce to_ty from_ty) expr
\end{code}
\begin{code}
%* *
%************************************************************************
+The default alternative must be first, if it exists at all.
+This makes it easy to find, though it makes matching marginally harder.
\begin{code}
+hasDefault :: [CoreAlt] -> Bool
+hasDefault ((DEFAULT,_,_) : alts) = True
+hasDefault _ = False
+
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)
+findDefault ((DEFAULT,args,rhs) : alts) = ASSERT( null args ) (alts, Just rhs)
+findDefault alts = (alts, Nothing)
findAlt :: AltCon -> [CoreAlt] -> CoreAlt
findAlt con alts
- = go alts
+ = case alts of
+ (deflt@(DEFAULT,_,_):alts) -> go alts deflt
+ other -> go alts panic_deflt
+
where
- go [] = pprPanic "Missing alternative" (ppr con $$ vcat (map ppr alts))
- go (alt : alts) | matches alt = alt
- | otherwise = go alts
+ panic_deflt = pprPanic "Missing alternative" (ppr con $$ vcat (map ppr alts))
- matches (DEFAULT, _, _) = True
- matches (con1, _, _) = con == con1
+ go [] deflt = deflt
+ go (alt@(con1,_,_) : alts) deflt | con == con1 = alt
+ | otherwise = ASSERT( not (con1 == DEFAULT) )
+ go alts deflt
\end{code}
(us1, us2) = splitUniqSupply us
uniq = uniqFromSupply us1
- ; Nothing ->
-
- case splitNewType_maybe ty of {
- Just ty' -> mkCoerce ty ty' (etaExpand n us (mkCoerce ty' ty expr) ty') ;
-
- Nothing -> pprTrace "Bad eta expand" (ppr expr $$ ppr ty) expr
- }}}
+ ; Nothing -> pprTrace "Bad eta expand" (ppr expr $$ ppr ty) expr
+ }}
\end{code}
cheapEqExpr (Var v1) (Var v2) = v1==v2
cheapEqExpr (Lit lit1) (Lit lit2) = lit1 == lit2
-cheapEqExpr (Type t1) (Type t2) = t1 == t2
+cheapEqExpr (Type t1) (Type t2) = t1 `eqType` t2
cheapEqExpr (App f1 a1) (App f2 a2)
= f1 `cheapEqExpr` f2 && a1 `cheapEqExpr` a2
\begin{code}
eqExpr :: CoreExpr -> CoreExpr -> Bool
-- Works ok at more general type, but only needed at CoreExpr
+ -- Used in rule matching, so when we find a type we use
+ -- eqTcType, which doesn't look through newtypes
+ -- [And it doesn't risk falling into a black hole either.]
eqExpr e1 e2
= eq emptyVarEnv e1 e2
where
env' = extendVarEnv env v1 v2
eq env (Note n1 e1) (Note n2 e2) = eq_note env n1 n2 && eq env e1 e2
- eq env (Type t1) (Type t2) = t1 == t2
+ eq env (Type t1) (Type t2) = t1 `eqType` t2
eq env e1 e2 = False
eq_list env [] [] = True
eq (extendVarEnvList env (vs1 `zip` vs2)) r1 r2
eq_note env (SCC cc1) (SCC cc2) = cc1 == cc2
- eq_note env (Coerce t1 f1) (Coerce t2 f2) = t1==t2 && f1==f2
+ eq_note env (Coerce t1 f1) (Coerce t2 f2) = t1 `eqType` t2 && f1 `eqType` f2
eq_note env InlineCall InlineCall = True
eq_note env other1 other2 = False
\end{code}
import SimplMonad
import Type ( Type, mkForAllTys, seqType, repType,
splitTyConApp_maybe, tyConAppArgs, mkTyVarTys,
- isDictTy, isDataType, isUnLiftedType,
+ isUnLiftedType,
splitRepFunTys
)
+import TcType ( isStrictType )
import TyCon ( tyConDataConsIfAvailable )
import DataCon ( dataConRepArity )
import VarEnv ( SubstEnv )
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
-- 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}
-- 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 / commitdiff