#include "HsVersions.h"
-import CmdLineOpts ( SimplifierSwitch(..),
- opt_SimplDoLambdaEtaExpansion, opt_SimplDoEtaReduction,
- opt_SimplCaseMerge, opt_UF_UpdateInPlace
- )
+import CmdLineOpts ( SimplifierSwitch(..), opt_UF_UpdateInPlace,
+ DynFlag(..), dopt )
import CoreSyn
-import CoreUtils ( cheapEqExpr, exprType,
+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
)
splitTyConApp_maybe, tyConAppArgs, mkTyVarTys
)
import TcType ( isDictTy )
+import Name ( mkSysTvName )
import OccName ( EncodedFS )
import TyCon ( tyConDataCons_maybe, isAlgTyCon, isNewTyCon )
import DataCon ( dataConRepArity, dataConExistentialTyVars, dataConArgTys )
-import Var ( mkSysTyVar, tyVarKind )
+import Var ( tyVarKind, mkTyVar )
+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)
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}
mkLam env bndrs body cont
- | opt_SimplDoEtaReduction,
- Just etad_lam <- tryEtaReduce bndrs body
- = tick (EtaReduction (head bndrs)) `thenSmpl_`
- returnSmpl (emptyFloats env, etad_lam)
-
- | opt_SimplDoLambdaEtaExpansion,
- any isRuntimeVar bndrs
- = tryEtaExpansion body `thenSmpl` \ body' ->
- returnSmpl (emptyFloats env, mkLams bndrs body')
+ = getDOptsSmpl `thenSmpl` \dflags ->
+ mkLam' dflags env bndrs body cont
+ where
+ mkLam' dflags env bndrs body cont
+ | dopt Opt_DoEtaReduction dflags,
+ Just etad_lam <- tryEtaReduce bndrs body
+ = tick (EtaReduction (head bndrs)) `thenSmpl_`
+ returnSmpl (emptyFloats env, etad_lam)
+
+ | dopt Opt_DoLambdaEtaExpansion dflags,
+ any isRuntimeVar bndrs
+ = tryEtaExpansion body `thenSmpl` \ body' ->
+ returnSmpl (emptyFloats env, mkLams bndrs body')
{- Sept 01: I'm experimenting with getting the
full laziness pass to float out past big lambdsa
returnSmpl (floats, mkLams bndrs body')
-}
- | otherwise
- = returnSmpl (emptyFloats env, mkLams bndrs body)
+ | otherwise
+ = returnSmpl (emptyFloats env, mkLams bndrs body)
\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)]
let
ex_tyvars = dataConExistentialTyVars missing_con
ex_tyvars' = zipWith mk tv_uniqs ex_tyvars
- mk uniq tv = mkSysTyVar uniq (tyVarKind tv)
+ mk uniq tv = mkTyVar (mkSysTvName uniq FSLIT("t")) (tyVarKind tv)
arg_tys = dataConArgTys missing_con (inst_tys ++ mkTyVarTys ex_tyvars')
arg_ids = zipWith (mkSysLocal FSLIT("a")) id_uniqs arg_tys
in
--------------------------------------------------
mkAlts scrut 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,
- scruting_same_var scrut_var
+ = getDOptsSmpl `thenSmpl` \dflags ->
+ mkAlts' dflags scrut outer_bndr outer_alts
+ where
+ mkAlts' dflags scrut outer_bndr outer_alts
+ | dopt Opt_CaseMerge dflags,
+ (outer_alts_without_deflt, maybe_outer_deflt) <- findDefault outer_alts,
+ Just (Case (Var scrut_var) inner_bndr inner_alts) <- maybe_outer_deflt,
+ scruting_same_var scrut_var
- = let -- Eliminate any inner alts which are shadowed by the outer ones
+ = let -- Eliminate any inner alts which are shadowed by the outer ones
outer_cons = [con | (con,_,_) <- outer_alts_without_deflt]
munged_inner_alts = [ (con, args, munge_rhs rhs)
-- mkCase applied to them, so they won't have a case in their default
-- Secondly, if you do, you get an infinite loop, because the bindCaseBndr
-- in munge_rhs may put a case into the DEFAULT branch!
- where
+ where
-- We are scrutinising the same variable if it's
-- the outer case-binder, or if the outer case scrutinises a variable
-- (and it's the same). Testing both allows us not to replace the
-- outer scrut-var with the outer case-binder (Simplify.simplCaseBinder).
- scruting_same_var = case scrut of
+ scruting_same_var = case scrut of
Var outer_scrut -> \ v -> v == outer_bndr || v == outer_scrut
other -> \ v -> v == outer_bndr
- add_default (Just rhs) alts = (DEFAULT,[],rhs) : alts
- add_default Nothing alts = alts
+ add_default (Just rhs) alts = (DEFAULT,[],rhs) : alts
+ add_default Nothing alts = alts
--------------------------------------------------
-- Catch-all
--------------------------------------------------
-mkAlts scrut case_bndr other_alts = returnSmpl other_alts
+ mkAlts' dflags scrut case_bndr other_alts = returnSmpl other_alts
\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_`
projects / ghc-hetmet.git / blobdiff