opt_SimplCaseMerge, opt_UF_UpdateInPlace
)
import CoreSyn
-import CoreUtils ( cheapEqExpr, exprType,
- etaExpand, exprEtaExpandArity, bindNonRec, mkCoerce,
+import CoreFVs ( exprFreeVars )
+import CoreUtils ( cheapEqExpr, exprType, exprIsTrivial,
+ etaExpand, exprEtaExpandArity, bindNonRec, mkCoerce2,
findDefault, exprOkForSpeculation, exprIsValue
)
import qualified Subst ( simplBndrs, simplBndr, simplLetId, simplLamBndr )
-import Id ( Id, idType, idInfo,
+import Id ( Id, idType, idInfo, isDataConWorkId,
mkSysLocal, isDeadBinder, idNewDemandInfo,
idUnfolding, idNewStrictness
)
import NewDemand ( isStrictDmd, isBotRes, splitStrictSig )
import SimplMonad
-import Type ( Type, seqType, splitRepFunTys, isStrictType,
+import Type ( Type, seqType, splitFunTys, dropForAlls, isStrictType,
splitTyConApp_maybe, tyConAppArgs, mkTyVarTys
)
import TcType ( isDictTy )
-import OccName ( UserFS )
+import OccName ( EncodedFS )
import TyCon ( tyConDataCons_maybe, isAlgTyCon, isNewTyCon )
-import DataCon ( dataConRepArity, dataConSig, dataConArgTys )
+import DataCon ( dataConRepArity, dataConExistentialTyVars, dataConArgTys )
import Var ( mkSysTyVar, tyVarKind )
+import VarSet
import Util ( lengthExceeds, mapAccumL )
import Outputable
\end{code}
-- * (error "Hello") arg
-- * f (error "Hello") where f is strict
-- etc
+ -- Then, especially in the first of these cases, we'd like to discard
+ -- the continuation, leaving just the bottoming expression. But the
+ -- type might not be right, so we may have to add a coerce.
go acc ss inl cont
| null ss && discardableCont cont = (reverse acc, discardCont cont, inl)
| otherwise = (reverse acc, cont, inl)
computed_stricts = zipWith (||) fun_stricts arg_stricts
----------------------------
- (val_arg_tys, _) = splitRepFunTys (idType fun)
+ (val_arg_tys, _) = splitFunTys (dropForAlls (idType fun))
arg_stricts = map isStrictType val_arg_tys ++ repeat False
-- These argument types are used as a cheap and cheerful way to find
-- unboxed arguments, which must be strict. But it's an InType
-- and so there might be a type variable where we expect a function
-- type (the substitution hasn't happened yet). And we don't bother
-- doing the type applications for a polymorphic function.
- -- Hence the split*Rep*FunTys
+ -- Hence the splitFunTys*IgnoringForAlls*
----------------------------
-- If fun_stricts is finite, it means the function returns bottom
interestingArg (Var v) = hasSomeUnfolding (idUnfolding v)
-- Was: isValueUnfolding (idUnfolding v')
-- But that seems over-pessimistic
+ || isDataConWorkId v
+ -- This accounts for an argument like
+ -- () or [], which is definitely interesting
interestingArg (Type _) = False
interestingArg (App fn (Type _)) = interestingArg fn
interestingArg (Note _ a) = interestingArg a
\begin{code}
-newId :: UserFS -> Type -> SimplM Id
+newId :: EncodedFS -> Type -> SimplM Id
newId fs ty = getUniqueSmpl `thenSmpl` \ uniq ->
returnSmpl (mkSysLocal fs uniq ty)
\end{code}
-- efficient here:
-- (a) we already have the binders
-- (b) we can do the triviality test before computing the free vars
- -- [in fact I take the simple path and look for just a variable]
= go (reverse bndrs) body
where
go (b : bs) (App fun arg) | ok_arg b arg = go bs fun -- Loop round
- go [] (Var fun) | ok_fun fun = Just (Var fun) -- Success!
+ go [] fun | ok_fun fun = Just fun -- Success!
go _ _ = Nothing -- Failure!
- ok_fun fun = not (fun `elem` bndrs) &&
- (isEvaldUnfolding (idUnfolding fun) || all ok_lam bndrs)
+ ok_fun fun = exprIsTrivial fun
+ && not (any (`elemVarSet` (exprFreeVars fun)) bndrs)
+ && (exprIsValue fun || all ok_lam bndrs)
ok_lam v = isTyVar v || isDictTy (idType v)
- -- The isEvaldUnfolding is because eta reduction is not
+ -- The exprIsValue is because eta reduction is not
-- valid in general: \x. bot /= bot
-- So we need to be sure that the "fun" is a value.
--
-- case x of { DEFAULT -> e }
-- and we don't want to fill in a default for them!
Just all_cons <- tyConDataCons_maybe tycon,
+ not (null all_cons), -- This is a tricky corner case. If the data type has no constructors,
+ -- which GHC allows, then the case expression will have at most a default
+ -- alternative. We don't want to eliminate that alternative, because the
+ -- invariant is that there's always one alternative. It's more convenient
+ -- to leave
+ -- case x of { DEFAULT -> e }
+ -- as it is, rather than transform it to
+ -- error "case cant match"
+ -- which would be quite legitmate. But it's a really obscure corner, and
+ -- not worth wasting code on.
let handled_data_cons = [data_con | DataAlt data_con <- handled_cons],
let missing_cons = [con | con <- all_cons,
not (con `elem` handled_data_cons)]
= getUniquesSmpl `thenSmpl` \ tv_uniqs ->
getUniquesSmpl `thenSmpl` \ id_uniqs ->
let
- (_,_,ex_tyvars,_,_,_) = dataConSig missing_con
+ ex_tyvars = dataConExistentialTyVars missing_con
ex_tyvars' = zipWith mk tv_uniqs ex_tyvars
mk uniq tv = mkSysTyVar uniq (tyVarKind tv)
arg_tys = dataConArgTys missing_con (inst_tys ++ mkTyVarTys ex_tyvars')
- arg_ids = zipWith (mkSysLocal SLIT("a")) id_uniqs arg_tys
+ arg_ids = zipWith (mkSysLocal FSLIT("a")) id_uniqs arg_tys
in
returnSmpl (ex_tyvars' ++ arg_ids)
\end{code}
\begin{code}
--------------------------------------------------
+-- 0. Check for empty alternatives
+--------------------------------------------------
+
+#ifdef DEBUG
+mkCase1 scrut case_bndr []
+ = pprTrace "mkCase1: null alts" (ppr case_bndr <+> ppr scrut) $
+ returnSmpl scrut
+#endif
+
+--------------------------------------------------
-- 1. Eliminate the case altogether if poss
--------------------------------------------------
-- 2. Identity case
--------------------------------------------------
-#ifdef DEBUG
-mkCase1 scrut case_bndr []
- = pprTrace "mkCase1: null alts" (ppr case_bndr <+> ppr scrut) $
- returnSmpl scrut
-#endif
-
mkCase1 scrut case_bndr alts -- Identity case
| all identity_alt alts
= tick (CaseIdentity case_bndr) `thenSmpl_`
-- 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
+ (_,_,rhs1@(Note _ _)) -> mkCoerce2 (exprType rhs1) (idType case_bndr) scrut
other -> scrut
projects / ghc-hetmet.git / blobdiff