\begin{code}
module SimplUtils (
- simplBinder, simplBinders, simplRecBndrs, simplLetBndr,
- simplLamBndrs, simplTopBndrs,
+ simplBinder, simplBinders, simplRecBndrs,
+ simplLetBndr, simplLamBndrs,
newId, mkLam, mkCase,
-- The continuation type
findDefault, exprOkForSpeculation, exprIsValue
)
import qualified Subst ( simplBndrs, simplBndr, simplLetId, simplLamBndr )
-import Id ( Id, idType, idInfo, isLocalId,
- mkSysLocal, hasNoBinding, isDeadBinder, idNewDemandInfo,
+import Id ( Id, idType, idInfo,
+ mkSysLocal, isDeadBinder, idNewDemandInfo,
idUnfolding, idNewStrictness
)
import NewDemand ( isStrictDmd, isBotRes, splitStrictSig )
import SimplMonad
-import Type ( Type, seqType,
- splitTyConApp_maybe, tyConAppArgs, mkTyVarTys,
- splitRepFunTys, isStrictType
+import Type ( Type, seqType, splitRepFunTys, isStrictType,
+ splitTyConApp_maybe, tyConAppArgs, mkTyVarTys
)
+import TcType ( isDictTy )
import OccName ( UserFS )
-import TyCon ( tyConDataConsIfAvailable, isAlgTyCon, isNewTyCon )
+import TyCon ( tyConDataCons_maybe, isAlgTyCon, isNewTyCon )
import DataCon ( dataConRepArity, dataConSig, dataConArgTys )
import Var ( mkSysTyVar, tyVarKind )
import Util ( lengthExceeds, mapAccumL )
InId [InAlt] SimplEnv -- The case binder, alts, and subst-env
SimplCont
- | ArgOf DupFlag -- An arbitrary strict context: the argument
+ | ArgOf LetRhsFlag -- An arbitrary strict context: the argument
-- of a strict function, or a primitive-arg fn
-- or a PrimOp
- LetRhsFlag
+ -- No DupFlag because we never duplicate it
+ OutType -- arg_ty: type of the argument itself
OutType -- cont_ty: the type of the expression being sought by the context
-- f (error "foo") ==> coerce t (error "foo")
-- when f is strict
-- We need to know the type t, to which to coerce.
+
(SimplEnv -> OutExpr -> SimplM FloatsWithExpr) -- What to do with the result
-- The result expression in the OutExprStuff has type cont_ty
instance Outputable SimplCont where
ppr (Stop _ is_rhs _) = ptext SLIT("Stop") <> brackets (ppr is_rhs)
ppr (ApplyTo dup arg se cont) = (ptext SLIT("ApplyTo") <+> ppr dup <+> ppr arg) $$ ppr cont
- ppr (ArgOf dup _ _ _) = ptext SLIT("ArgOf...") <+> ppr dup
+ ppr (ArgOf _ _ _ _) = ptext SLIT("ArgOf...")
ppr (Select dup bndr alts se cont) = (ptext SLIT("Select") <+> ppr dup <+> ppr bndr) $$
(nest 4 (ppr alts)) $$ ppr cont
ppr (CoerceIt ty cont) = (ptext SLIT("CoerceIt") <+> ppr ty) $$ ppr cont
contIsRhs :: SimplCont -> Bool
contIsRhs (Stop _ AnRhs _) = True
-contIsRhs (ArgOf _ AnRhs _ _) = True
+contIsRhs (ArgOf AnRhs _ _ _) = True
contIsRhs other = False
contIsRhsOrArg (Stop _ _ _) = True
contIsDupable :: SimplCont -> Bool
contIsDupable (Stop _ _ _) = True
contIsDupable (ApplyTo OkToDup _ _ _) = True
-contIsDupable (ArgOf OkToDup _ _ _) = True
contIsDupable (Select OkToDup _ _ _ _) = True
contIsDupable (CoerceIt _ cont) = contIsDupable cont
contIsDupable (InlinePlease cont) = contIsDupable cont
| otherwise
= case splitTyConApp_maybe ty of
Nothing -> False
- Just (tycon, _) -> case tyConDataConsIfAvailable tycon of
- [dc] -> arity == 1 || arity == 2
- where
- arity = dataConRepArity dc
+ Just (tycon, _) -> case tyConDataCons_maybe tycon of
+ Just [dc] -> arity == 1 || arity == 2
+ where
+ arity = dataConRepArity dc
other -> False
\end{code}
seqBndr id' `seq`
returnSmpl (setSubst env subst', id')
-simplTopBndrs, simplLamBndrs, simplRecBndrs
+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
go [] (Var fun) | ok_fun fun = Just (Var fun) -- Success!
go _ _ = Nothing -- Failure!
- ok_fun fun = not (fun `elem` bndrs) && not (hasNoBinding fun)
- -- Note the awkward "hasNoBinding" test
- -- Details with exprIsTrivial
+ ok_fun fun = not (fun `elem` bndrs) &&
+ (isEvaldUnfolding (idUnfolding fun) || all ok_lam bndrs)
+ ok_lam v = isTyVar v || isDictTy (idType v)
+ -- The isEvaldUnfolding is because eta reduction is not
+ -- valid in general: \x. bot /= bot
+ -- So we need to be sure that the "fun" is a value.
+ --
+ -- However, we always want to reduce (/\a -> f a) to f
+ -- This came up in a RULE: foldr (build (/\a -> g a))
+ -- did not match foldr (build (/\b -> ...something complex...))
+ -- The type checker can insert these eta-expanded versions,
+ -- with both type and dictionary lambdas; hence the slightly
+ -- ad-hoc isDictTy
+
ok_arg b arg = varToCoreExpr b `cheapEqExpr` arg
\end{code}
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),
- isAlgTyCon tycon, -- It's a data type, tuple, or unboxed tuples.
- -- We aren't expecting any newtypes at this point.
- (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!
- = ASSERT( not (isNewTyCon tycon) )
- tick (FillInCaseDefault case_bndr) `thenSmpl_`
+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!
+
+ Just all_cons <- tyConDataCons_maybe tycon,
+ [missing_con] <- [con | con <- all_cons, 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 ->
let
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}
If so, then we can replace the case with one of the rhss.
+Further notes about case elimination
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider: test :: Integer -> IO ()
+ test = print
+
+Turns out that this compiles to:
+ Print.test
+ = \ eta :: Integer
+ eta1 :: State# RealWorld ->
+ case PrelNum.< eta PrelNum.zeroInteger of wild { __DEFAULT ->
+ case hPutStr stdout
+ (PrelNum.jtos eta ($w[] @ Char))
+ eta1
+ of wild1 { (# new_s, a4 #) -> PrelIO.lvl23 new_s }}
+
+Notice the strange '<' which has no effect at all. This is a funny one.
+It started like this:
+
+f x y = if x < 0 then jtos x
+ else if y==0 then "" else jtos x
+
+At a particular call site we have (f v 1). So we inline to get
+
+ if v < 0 then jtos x
+ else if 1==0 then "" else jtos x
+
+Now simplify the 1==0 conditional:
+
+ if v<0 then jtos v else jtos v
+
+Now common-up the two branches of the case:
+
+ case (v<0) of DEFAULT -> jtos v
+
+Why don't we drop the case? Because it's strict in v. It's technically
+wrong to drop even unnecessary evaluations, and in practice they
+may be a result of 'seq' so we *definitely* don't want to drop those.
+I don't really know how to improve this situation.
+
\begin{code}
--------------------------------------------------
-- Here we must *not* discard the case, because dataToTag# just fetches the tag from
-- the info pointer. So we'll be pedantic all the time, and see if that gives any
-- other problems
+-- Also we don't want to discard 'seq's
= tick (CaseElim case_bndr) `thenSmpl_`
returnSmpl (bindCaseBndr case_bndr scrut rhs)
projects / ghc-hetmet.git / blobdiff