\begin{code}
module SimplUtils (
- simplBinder, simplBinders, simplRecIds, simplLetId, simplLamBinders,
+ simplBinder, simplBinders, simplRecBndrs, simplLetBndr,
+ simplLamBndrs, simplTopBndrs,
newId, mkLam, mkCase,
-- The continuation type
findDefault, exprOkForSpeculation, exprIsValue
)
import qualified Subst ( simplBndrs, simplBndr, simplLetId, simplLamBndr )
-import Id ( Id, idType, idInfo,
+import Id ( Id, idType, idInfo, isLocalId,
mkSysLocal, hasNoBinding, isDeadBinder, idNewDemandInfo,
idUnfolding, idNewStrictness
)
splitRepFunTys, isStrictType
)
import OccName ( UserFS )
-import TyCon ( tyConDataConsIfAvailable, isDataTyCon )
+import TyCon ( tyConDataConsIfAvailable, isAlgTyCon, isNewTyCon )
import DataCon ( dataConRepArity, dataConSig, dataConArgTys )
import Var ( mkSysTyVar, tyVarKind )
import Util ( lengthExceeds, mapAccumL )
returnSmpl (setSubst env subst', bndr')
-simplLamBinders :: SimplEnv -> [InBinder] -> SimplM (SimplEnv, [OutBinder])
-simplLamBinders env bndrs
- = let
- (subst', bndrs') = mapAccumL Subst.simplLamBndr (getSubst env) bndrs
- in
- seqBndrs bndrs' `seq`
- returnSmpl (setSubst env subst', bndrs')
-
-simplRecIds :: SimplEnv -> [InBinder] -> SimplM (SimplEnv, [OutBinder])
-simplRecIds env ids
- = let
- (subst', ids') = mapAccumL Subst.simplLetId (getSubst env) ids
- in
- seqBndrs ids' `seq`
- returnSmpl (setSubst env subst', ids')
-
-simplLetId :: SimplEnv -> InBinder -> SimplM (SimplEnv, OutBinder)
-simplLetId env id
+simplLetBndr :: SimplEnv -> InBinder -> SimplM (SimplEnv, OutBinder)
+simplLetBndr env id
= let
(subst', id') = Subst.simplLetId (getSubst env) id
in
seqBndr id' `seq`
returnSmpl (setSubst env subst', id')
+simplTopBndrs, simplLamBndrs, simplRecBndrs
+ :: SimplEnv -> [InBinder] -> SimplM (SimplEnv, [OutBinder])
+simplTopBndrs = simplBndrs simplTopBinder
+simplRecBndrs = simplBndrs Subst.simplLetId
+simplLamBndrs = simplBndrs Subst.simplLamBndr
+
+-- For top-level binders, don't use simplLetId for GlobalIds.
+-- There are some of these, notably consructor wrappers, and we don't
+-- want to clone them or fiddle with them at all.
+-- Rather tiresomely, the specialiser may float a use of a constructor
+-- wrapper to before its definition (which shouldn't really matter)
+-- because it doesn't see the constructor wrapper as free in the binding
+-- it is floating (because it's a GlobalId).
+-- Then the simplifier brings all top level Ids into scope at the
+-- beginning, and we don't want to lose the IdInfo on the constructor
+-- wrappers. It would also be Bad to clone it!
+simplTopBinder subst bndr
+ | isLocalId bndr = Subst.simplLetId subst bndr
+ | otherwise = (subst, bndr)
+
+simplBndrs simpl_bndr env bndrs
+ = let
+ (subst', bndrs') = mapAccumL simpl_bndr (getSubst env) bndrs
+ in
+ seqBndrs bndrs' `seq`
+ returnSmpl (setSubst env subst', bndrs')
+
seqBndrs [] = ()
seqBndrs (b:bs) = seqBndr b `seq` seqBndrs bs
mkCase puts a case expression back together, trying various transformations first.
\begin{code}
-mkCase :: OutExpr -> OutId -> [OutAlt] -> SimplM OutExpr
+mkCase :: OutExpr -> [AltCon] -> OutId -> [OutAlt] -> SimplM OutExpr
-mkCase scrut case_bndr alts
- = mkAlts scrut case_bndr alts `thenSmpl` \ better_alts ->
+mkCase scrut handled_cons case_bndr alts
+ = mkAlts scrut handled_cons case_bndr alts `thenSmpl` \ better_alts ->
mkCase1 scrut case_bndr better_alts
\end{code}
--------------------------------------------------
-- 1. Merge identical branches
--------------------------------------------------
-mkAlts scrut case_bndr alts@((con1,bndrs1,rhs1) : con_alts)
+mkAlts scrut handled_cons case_bndr alts@((con1,bndrs1,rhs1) : con_alts)
| all isDeadBinder bndrs1, -- Remember the default
length filtered_alts < length con_alts -- alternative comes first
= tick (AltMerge case_bndr) `thenSmpl_`
-- 2. Fill in missing constructor
--------------------------------------------------
-mkAlts scrut case_bndr alts
- | Just (tycon, inst_tys) <- splitTyConApp_maybe (idType case_bndr),
- isDataTyCon tycon, -- It's a data type
- (alts_no_deflt, Just rhs) <- findDefault alts,
- -- There is a DEFAULT case
- [missing_con] <- filter is_missing (tyConDataConsIfAvailable tycon)
- -- There is just one missing constructor!
+mkAlts scrut handled_cons case_bndr alts
+ | (alts_no_deflt, Just rhs) <- findDefault alts,
+ -- There is a DEFAULT case
+
+ Just (tycon, inst_tys) <- splitTyConApp_maybe (idType case_bndr),
+ isAlgTyCon tycon, -- It's a data type, tuple, or unboxed tuples.
+ not (isNewTyCon tycon), -- We can have a newtype, if we are just doing an eval:
+ -- case x of { DEFAULT -> e }
+ -- and we don't want to fill in a default for them!
+
+ [missing_con] <- [con | con <- tyConDataConsIfAvailable tycon,
+ not (con `elem` handled_data_cons)]
+ -- There is just one missing constructor!
+
= tick (FillInCaseDefault case_bndr) `thenSmpl_`
getUniquesSmpl `thenSmpl` \ tv_uniqs ->
getUniquesSmpl `thenSmpl` \ id_uniqs ->
in
returnSmpl better_alts
where
- impossible_cons = otherCons (idUnfolding case_bndr)
- handled_data_cons = [data_con | DataAlt data_con <- impossible_cons] ++
- [data_con | (DataAlt data_con, _, _) <- alts]
- is_missing con = not (con `elem` handled_data_cons)
+ handled_data_cons = [data_con | DataAlt data_con <- handled_cons]
--------------------------------------------------
-- 3. Merge nested cases
--------------------------------------------------
-mkAlts scrut outer_bndr outer_alts
+mkAlts scrut handled_cons outer_bndr outer_alts
| opt_SimplCaseMerge,
(outer_alts_without_deflt, maybe_outer_deflt) <- findDefault outer_alts,
Just (Case (Var scrut_var) inner_bndr inner_alts) <- maybe_outer_deflt,
-- Catch-all
--------------------------------------------------
-mkAlts scrut case_bndr other_alts = returnSmpl other_alts
+mkAlts scrut handled_cons case_bndr other_alts = returnSmpl other_alts
\end{code}