#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 CoreFVs ( exprFreeVars )
import CoreUtils ( cheapEqExpr, exprType, exprIsTrivial,
findDefault, exprOkForSpeculation, exprIsValue
)
import qualified Subst ( simplBndrs, simplBndr, simplLetId, simplLamBndr )
-import Id ( Id, idType, idInfo, isDataConId,
+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
-- * (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
- || isDataConId v
+ || isDataConWorkId v
-- This accounts for an argument like
-- () or [], which is definitely interesting
interestingArg (Type _) = False
\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}
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}
projects / ghc-hetmet.git / blobdiff