Several bugfixes (from SLPJ's tree).
isConstantId, isBottomingId, idAppIsBottom,
isExportedId, isUserExportedId,
+ -- One shot lambda stuff
+ isOneShotLambda, setOneShotLambda,
+
-- IdInfo stuff
setIdUnfolding,
setIdArity,
IMustBeINLINEd -> True
other -> False
\end{code}
+
+
+ ---------------------------------
+ -- ONE-SHOT LAMBDAS
+\begin{code}
+isOneShotLambda :: Id -> Bool
+isOneShotLambda id = case lbvarInfo (idInfo id) of
+ IsOneShotLambda -> True
+ NoLBVarInfo -> False
+
+setOneShotLambda :: Id -> Id
+setOneShotLambda id = modifyIdInfo (`setLBVarInfo` IsOneShotLambda) id
+\end{code}
= Just (info {inlinePragInfo = safe_inline_prag,
demandInfo = wwLazy})
where
+ -- The "unsafe" prags are the ones that say I'm not in a lambda
+ -- because that might not be true for an unsaturated lambda
is_safe_inline_prag = case inline_prag of
- ICanSafelyBeINLINEd dup_danger nalts -> notInsideLambda dup_danger
- other -> True
+ ICanSafelyBeINLINEd NotInsideLam nalts -> False
+ other -> True
safe_inline_prag = case inline_prag of
ICanSafelyBeINLINEd _ nalts
data LBVarInfo
= NoLBVarInfo
- | IsOneShotLambda -- the lambda that binds this Id is applied
- -- at most once
+ | IsOneShotLambda -- The lambda that binds this Id is applied
+ -- at most once
-- HACK ALERT! placing this info here is a short-term hack,
-- but it minimises changes to the rest of the compiler.
-- Hack agreed by SLPJ/KSW 1999-04.
\end{code}
\begin{code}
-
noLBVarInfo = NoLBVarInfo
-- not safe to print or parse LBVarInfo because it is not really a
import PrelMods ( pREL_ERR, pREL_GHC )
import Type ( Type, ThetaType,
mkDictTy, mkTyConApp, mkTyVarTys, mkFunTys, mkFunTy, mkSigmaTy,
- isUnLiftedType, mkForAllTys, mkTyVarTy,
+ isUnLiftedType, mkForAllTys, mkTyVarTy, tyVarsOfTypes,
splitSigmaTy, splitFunTy_maybe, splitAlgTyConApp,
splitFunTys, splitForAllTys, unUsgTy,
mkUsgTy, UsageAnn(..)
import TyCon ( TyCon, isNewTyCon, tyConDataCons, isDataTyCon )
import Class ( Class, classBigSig, classTyCon )
import Var ( Id, TyVar )
-import VarEnv ( zipVarEnv )
+import VarSet ( isEmptyVarSet )
import Const ( Con(..) )
import Name ( mkDerivedName, mkWiredInIdName, mkLocalName,
mkWorkerOcc, mkSuperDictSelOcc,
-- want to have any dict arguments, so that we can
-- expose the constant methods.
- other -> nub (inst_decl_theta ++ sc_theta')
+ other -> nub (inst_decl_theta ++ filter not_const sc_theta')
-- Otherwise we pass the superclass dictionaries to
-- the dictionary function; the Mark Jones optimisation.
--
-- instance Monad m => MonadT (EnvT env) m where ...
-- Here, the inst_decl_theta has (Monad m); but so
-- does the sc_theta'!
+ --
+ -- NOTE the "not_const". I got caught by this one too:
+ -- class Foo a => Baz a b where ...
+ -- instance Wob b => Baz T b where..
+ -- Now sc_theta' has Foo T
dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_tys)
+
+ not_const (clas, tys) = not (isEmptyVarSet (tyVarsOfTypes tys))
\end{code}
getKey, -- Used in Var only!
incrUnique, -- Used for renumbering
+ deriveUnique, -- Ditto
initTyVarUnique,
initTidyUniques,
getKey :: Unique -> Int# -- for Var
incrUnique :: Unique -> Unique
+deriveUnique :: Unique -> Int -> Unique
\end{code}
{-# INLINE getKey #-}
getKey (MkUnique x) = x
-incrUnique (MkUnique i) = MkUnique (i +# 100#)
--- Bump the unique by a lot, to get it out of the neighbourhood
--- of its friends
+incrUnique (MkUnique i) = MkUnique (i +# 1#)
+
+-- deriveUnique uses an 'X' tag so that it won't clash with
+-- any of the uniques produced any other way
+deriveUnique (MkUnique i) delta = mkUnique 'X' (I# i + delta)
-- pop the Char in the top 8 bits of the Unique(Supply)
i2w_s x = (x::Int#)
mkUnique (C# c) (I# i)
- = MkUnique (w2i (((i2w (ord# c)) `shiftL#` (i2w_s 24#)) `or#` (i2w i)))
+ = MkUnique (w2i (tag `or#` bits))
+ where
+ tag = i2w (ord# c) `shiftL#` i2w_s 24#
+ bits = i2w i `and#` (i2w 16777215#){-``0x00ffffff''-}
unpkUnique (MkUnique u)
= let
tag = C# (chr# (w2i ((i2w u) `shiftr` (i2w_s 24#))))
- i = I# (w2i ((i2w u) `and#` (i2w 16777215#){-``0x00ffffff''-}))
+ i = I# (w2i ((i2w u) `and#` (i2w 16777215#){-``0x00ffffff''-}))
in
(tag, i)
where
other a-z: lower case chars for unique supplies (see Main.lhs)
B: builtin
C-E: pseudo uniques (used in native-code generator)
+ X: uniques derived by deriveUnique
_: unifiable tyvars (above)
0-9: prelude things below
1 type Id = Var ;
1 data Var ;
1 setIdName _:_ Id -> Name.Name -> Id ;;
-
import CmdLineOpts ( opt_PprStyle_Debug )
import Var ( Var, Id, TyVar, IdOrTyVar, setVarUnique )
-import Unique ( Unique, Uniquable(..), incrUnique )
+import Unique ( Unique, Uniquable(..), incrUnique, deriveUnique )
import UniqSet
import UniqFM ( delFromUFM_Directly )
import Outputable
| not (var `elemVarSet` set) = var -- Nothing to do
| otherwise
- = try 1 (incrUnique (getUnique var))
+ = try 1 (deriveUnique (getUnique var) (hashUniqSet set))
where
try n uniq | uniq `elemUniqSet_Directly` set = try ((n+1)::Int) (incrUnique uniq)
#ifdef DEBUG
__interface CgBindery 1 0 where
__export CgBindery CgBindings CgIdInfo{MkCgIdInfo} VolatileLoc StableLoc nukeVolatileBinds maybeStkLoc;
1 type CgBindings = VarEnv.IdEnv CgIdInfo;
-1 data CgIdInfo = MkCgIdInfo Var.Id VolatileLoc StableLoc ClosureInfo!LambdaFormInfo;
+1 data CgIdInfo = MkCgIdInfo Var.Id VolatileLoc StableLoc ClosureInfo.LambdaFormInfo;
1 data VolatileLoc;
1 data StableLoc;
1 nukeVolatileBinds :: CgBindings -> CgBindings ;
_interface_ CgExpr 1
_exports_
-CgExpr cgExpr;
+CgExpr cgExpr ;
_declarations_
1 cgExpr _:_ StgSyn.StgExpr -> CgMonad.Code ;;
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgHeapery.lhs,v 1.16 1999/05/13 17:30:56 simonm Exp $
+% $Id: CgHeapery.lhs,v 1.17 1999/05/26 14:12:13 simonmar Exp $
%
\section[CgHeapery]{Heap management functions}
CCheck HP_CHK_NOREGS [mkIntCLit words_required] AbsCNop
-- The SEQ case (polymophic/function typed case branch)
+ -- We need this case because the closure in Node won't return
+ -- directly when we enter it (it could be a function), so the
+ -- heap check code needs to push a seq frame on top of the stack.
[VanillaReg rep ILIT(1)]
| rep == PtrRep
&& is_fun ->
module CoreUtils (
coreExprType, coreAltsType,
- exprIsBottom, exprIsDupable, exprIsTrivial, exprIsWHNF, exprIsCheap,
+ exprIsBottom, exprIsDupable, exprIsTrivial, exprIsWHNF, exprIsCheap, exprIsValue,
exprOkForSpeculation,
FormSummary(..), mkFormSummary, whnfOrBottom, exprArity,
cheapEqExpr, eqExpr, applyTypeToArgs
\begin{code}
mkFormSummary :: CoreExpr -> FormSummary
+ -- Used exclusively by CoreUnfold.mkUnfolding
+ -- Returns ValueForm for cheap things, not just values
mkFormSummary expr
= go (0::Int) expr -- The "n" is the number of *value* arguments so far
where
go n (Let (NonRec b r) e) | exprIsCheap r = go n e -- let f = f' alpha in (f,g)
-- should be treated as a value
- go n (Let _ e) = OtherForm
+ go n (Let _ e) = OtherForm
-- We want selectors to look like values
-- e.g. case x of { (a,b) -> a }
where op is a cheap primitive operator
+Notice that a variable is considered 'cheap': we can push it inside a lambda,
+because sharing will make sure it is only evaluated once.
+
\begin{code}
exprIsCheap :: CoreExpr -> Bool
exprIsCheap (Type _) = True
go n (Lam _ _) = False
\end{code}
+@exprIsValue@ returns true for expressions that are evaluated.
+It does not treat variables as evaluated.
+
+\begin{code}
+exprIsValue :: CoreExpr -> Bool -- True => Value-lambda, constructor, PAP
+exprIsValue (Type ty) = True -- Types are honorary Values; we don't mind
+ -- copying them
+exprIsValue (Var v) = False
+exprIsValue (Lam b e) = isId b || exprIsValue e
+exprIsValue (Note _ e) = exprIsValue e
+exprIsValue (Let _ e) = False
+exprIsValue (Case _ _ _) = False
+exprIsValue (Con con _) = isWHNFCon con
+exprIsValue e@(App _ _) = case collectArgs e of
+ (Var v, args) -> fun_arity > valArgCount args
+ where
+ fun_arity = arityLowerBound (getIdArity v)
+ _ -> False
+\end{code}
+
exprIsWHNF reports True for head normal forms. Note that does not necessarily
mean *normal* forms; constructors might have non-trivial argument expressions, for
example. We use a let binding for WHNFs, rather than a case binding, even if it's
used strictly. We try to expose WHNFs by floating lets out of the RHS of lets.
-We treat applications of buildId and augmentId as honorary WHNFs, because we
-want them to get exposed
+ We treat applications of buildId and augmentId as honorary WHNFs,
+ because we want them to get exposed.
+ [May 99: I've disabled this because it looks jolly dangerous:
+ we'll substitute inside lambda with potential big loss of sharing.]
\begin{code}
exprIsWHNF :: CoreExpr -> Bool -- True => Variable, value-lambda, constructor, PAP
exprIsWHNF (Case _ _ _) = False
exprIsWHNF (Con con _) = isWHNFCon con
exprIsWHNF e@(App _ _) = case collectArgs e of
- (Var v, args) -> n_val_args == 0 ||
- fun_arity > n_val_args ||
- v_uniq == buildIdKey ||
- v_uniq == augmentIdKey
+ (Var v, args) -> n_val_args == 0
+ || fun_arity > n_val_args
+-- [May 99: disabled. See note above] || v_uniq == buildIdKey
+-- || v_uniq == augmentIdKey
where
n_val_args = valArgCount args
fun_arity = arityLowerBound (getIdArity v)
_declarations_
1 data HsExpr i p;
1 pprExpr _:_ _forall_ [i p] {Outputable.Outputable i, Outputable.Outputable p} => HsExpr.HsExpr i p -> Outputable.SDoc ;;
-
let
main_name = availName avail
new_decls_map = foldl add_decl decls_map
- [ (name, (version, avail, name==main_name, (mod, decl)))
+ [ (name, (version, avail, name==main_name, (mod, decl')))
| name <- sys_bndrs ++ availNames avail]
add_decl decls_map (name, stuff)
= WARN( name `elemNameEnv` decls_map, ppr name )
bindIO_NAME
)
import Bag ( bagToList )
-import List ( partition )
+import List ( partition, nub )
import Outputable
import SrcLoc ( SrcLoc )
import CmdLineOpts ( opt_WarnUnusedMatches ) -- Warn of unused for-all'd tyvars
False
tys
+freeRdrTyVars :: RdrNameHsType -> [RdrName]
+freeRdrTyVars ty = filter isRdrTyVar (extractHsTyRdrNames ty)
rnHsType :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars)
-- over FV(T) \ {in-scope-tyvars}
= getLocalNameEnv `thenRn` \ name_env ->
let
- mentioned_tyvars = filter isRdrTyVar (extractHsTyRdrNames ty)
- forall_tyvars = filter (not . (`elemFM` name_env)) mentioned_tyvars
+ mentioned_in_tau = freeRdrTyVars ty
+ forall_tyvars = filter (not . (`elemFM` name_env)) mentioned_in_tau
in
checkConstraints False doc forall_tyvars ctxt ty `thenRn` \ ctxt' ->
rnForAll doc (map UserTyVar forall_tyvars) ctxt' ty
-rnHsType doc (HsForAllTy (Just forall_tyvars) ctxt ty)
+rnHsType doc (HsForAllTy (Just forall_tyvars) ctxt tau)
-- Explicit quantification.
-- Check that the forall'd tyvars are a subset of the
-- free tyvars in the tau-type part
-- That's only a warning... unless the tyvar is constrained by a
-- context in which case it's an error
= let
- mentioned_tyvars = filter isRdrTyVar (extractHsTyRdrNames ty)
- constrained_tyvars = [tv | (_,tys) <- ctxt,
+ mentioned_in_tau = freeRdrTyVars tau
+ mentioned_in_ctxt = nub [tv | (_,tys) <- ctxt,
ty <- tys,
- tv <- mentioned_tyvars]
- dubious_guys = filter (`notElem` mentioned_tyvars) forall_tyvar_names
- (bad_guys, warn_guys) = partition (`elem` constrained_tyvars) dubious_guys
+ tv <- freeRdrTyVars ty]
+
+ dubious_guys = filter (`notElem` mentioned_in_tau) forall_tyvar_names
+ -- dubious = explicitly quantified but not mentioned in tau type
+
+ (bad_guys, warn_guys) = partition (`elem` mentioned_in_ctxt) dubious_guys
+ -- bad = explicitly quantified and constrained, but not mentioned in tau
+ -- warn = explicitly quantified but not mentioned in ctxt or tau
+
forall_tyvar_names = map getTyVarName forall_tyvars
in
- mapRn_ (forAllErr doc ty) bad_guys `thenRn_`
- mapRn_ (forAllWarn doc ty) warn_guys `thenRn_`
- checkConstraints True doc forall_tyvar_names ctxt ty `thenRn` \ ctxt' ->
- rnForAll doc forall_tyvars ctxt' ty
+ mapRn_ (forAllErr doc tau) bad_guys `thenRn_`
+ mapRn_ (forAllWarn doc tau) warn_guys `thenRn_`
+ checkConstraints True doc forall_tyvar_names ctxt tau `thenRn` \ ctxt' ->
+ rnForAll doc forall_tyvars ctxt' tau
rnHsType doc (MonoTyVar tyvar)
= lookupOccRn tyvar `thenRn` \ tyvar' ->
(ptext SLIT("In") <+> doc))
ctxtErr explicit_forall doc tyvars constraint ty
- = sep [ptext SLIT("The constraint") <+> quotes (pprClassAssertion constraint) <+>
+ = sep [ptext SLIT("None of the type variable(s) in the constraint") <+> quotes (pprClassAssertion constraint) <+>
ptext SLIT("does not mention any of"),
if explicit_forall then
- nest 4 (ptext SLIT("the universally quantified type variables") <+> braces (interpp'SP tyvars))
+ nest 4 (ptext SLIT("is universally quantified (i.e. bound by the forall)"))
else
- nest 4 (ptext SLIT("the type variables in the type") <+> quotes (ppr ty))
+ nest 4 (ptext SLIT("appears in the type") <+> quotes (ppr ty))
]
$$
(ptext SLIT("In") <+> doc)
import CoreLint ( beginPass, endPass )
import Const ( isDataCon )
import CoreFVs ( CoreExprWithFVs, freeVars, freeVarsOf )
-import Var ( Id, idType )
+import Id ( isOneShotLambda )
+import Var ( Id, idType, isTyVar )
import Type ( isUnLiftedType )
import VarSet
import Util ( zipEqual )
[drop_here, fun_drop, arg_drop] = sepBindsByDropPoint [freeVarsOf fun, freeVarsOf arg] to_drop
\end{code}
-We are careful about lambdas:
+We are careful about lambdas:
-* We never float inside a value lambda. That risks losing laziness.
+* We must be careful about floating inside inside a value lambda.
+ That risks losing laziness.
The float-out pass might rescue us, but then again it might not.
-* We don't float inside type lambdas either. At one time we did, and
+* We must be careful about type lambdas too. At one time we did, and
there is no risk of duplicating work thereby, but we do need to be
careful. In particular, here is a bad case (it happened in the
cichelli benchmark:
This is bad as now f is an updatable closure (update PAP)
and has arity 0.
-So the simple thing is never to float inside big lambda either.
-Maybe we'll find cases when that loses something important; if
-so we can modify the decision.
+So we treat lambda in groups, using the following rule:
+
+ Float inside a group of lambdas only if
+ they are all either type lambdas or one-shot lambdas.
+
+ Otherwise drop all the bindings outside the group.
\begin{code}
fiExpr to_drop (_, AnnLam b body)
- = mkCoLets' to_drop (Lam b (fiExpr [] body))
+ = case collect [b] body of
+ (bndrs, real_body)
+ | all is_ok bndrs -> mkLams bndrs (fiExpr to_drop real_body)
+ | otherwise -> mkCoLets' to_drop (mkLams bndrs (fiExpr [] real_body))
+ where
+ collect bs (_, AnnLam b body) = collect (b:bs) body
+ collect bs body = (reverse bs, body)
+
+ is_ok bndr = isTyVar bndr || isOneShotLambda bndr
\end{code}
We don't float lets inwards past an SCC.
import CoreUtils ( coreExprType, exprIsTrivial, exprIsBottom )
import CoreFVs -- all of it
-import Id ( Id, idType, mkSysLocal )
+import Id ( Id, idType, mkSysLocal, isOneShotLambda )
import Var ( IdOrTyVar, Var, setVarUnique )
import VarEnv
import VarSet
bndr_is_tyvar = isTyVar bndr
(bndrs, body) = go rhs
- incd_lvl | bndr_is_id = incMajorLvl ctxt_lvl
- | otherwise = incMinorLvl ctxt_lvl
+ incd_lvl | bndr_is_id && not (all isOneShotLambda bndrs) = incMajorLvl ctxt_lvl
+ | otherwise = incMinorLvl ctxt_lvl
+ -- Only bump the major level number if the binders include
+ -- at least one more-than-one-shot lambda
+
lvld_bndrs = [(b,incd_lvl) | b <- (bndr:bndrs)]
new_env = extendLvlEnv env lvld_bndrs
way of the above scheme. And anyway, IO is the only guaranteed
way to enforce ordering --SDM.
-3. Mangle cases involving seq# in the discriminant. Up to this
- point, seq# will appear like this:
-
- case seq# e of
- 0# -> seqError#
- _ -> ...
-
- where the 0# branch is purely to bamboozle the strictness analyser
- (see case 4 above). This code comes from an unfolding for 'seq'
- in Prelude.hs. We translate this into
-
- case e of
- _ -> ...
-
- Now that the evaluation order is safe.
-
4. Do eta reduction for lambda abstractions appearing in:
- the RHS of case alternatives
- the body of a let
= postSimplExprEta body `thenPM` \ body' ->
returnPM (Note note body')
--- seq#: see notes above.
--- NB: seq# :: forall a. a -> Int#
-postSimplExpr (Case scrut@(Con (PrimOp SeqOp) [Type ty, e]) bndr alts)
- = postSimplExpr e `thenPM` \ e' ->
- let
- -- The old binder can't have been used, so we
- -- can gaily re-use it (yuk!)
- new_bndr = setIdType bndr ty
- in
- postSimplExprEta default_rhs `thenPM` \ rhs' ->
- returnPM (Case e' new_bndr [(DEFAULT,[],rhs')])
- where
- (other_alts, maybe_default) = findDefault alts
- Just default_rhs = maybe_default
-
-- par#: see notes above.
postSimplExpr (Case scrut@(Con (PrimOp op) args) bndr alts)
| funnyParallelOp op && maybeToBool maybe_default
getIdDemandInfo, setIdDemandInfo,
getIdArity, setIdArity,
getIdStrictness,
- setInlinePragma, getInlinePragma, idMustBeINLINEd
+ setInlinePragma, getInlinePragma, idMustBeINLINEd,
+ setOneShotLambda
)
import IdInfo ( InlinePragInfo(..), OccInfo(..), StrictnessInfo(..),
ArityInfo(..), atLeastArity, arityLowerBound, unknownArity,
import CoreUnfold ( Unfolding(..), mkUnfolding, callSiteInline,
isEvaldUnfolding, blackListed )
import CoreUtils ( cheapEqExpr, exprIsDupable, exprIsWHNF, exprIsTrivial,
- coreExprType, coreAltsType, exprArity,
+ coreExprType, coreAltsType, exprArity, exprIsValue,
exprOkForSpeculation
)
import Rules ( lookupRule )
-> Int -- Number of args
-> Id -> Id -- Use this to zap the binders
mkLamBndrZapper fun n_args
- | saturated fun n_args = \b -> b
- | otherwise = \b -> maybeModifyIdInfo zapLamIdInfo b
+ | n_args >= n_params fun = \b -> b -- Enough args
+ | otherwise = \b -> maybeModifyIdInfo zapLamIdInfo b
where
- saturated (Lam b e) 0 = False
- saturated (Lam b e) n = saturated e (n-1)
- saturated e n = True
+ n_params (Lam b e) | isId b = 1 + n_params e
+ | otherwise = n_params e
+ n_params other = 0::Int
\end{code}
-- Value argument
go (Lam bndr fun) (arg:args)
- | preInlineUnconditionally bndr && not opt_SimplNoPreInlining
+ | preInlineUnconditionally zapped_bndr && not opt_SimplNoPreInlining
= tick (BetaReduction bndr) `thenSmpl_`
tick (PreInlineUnconditionally bndr) `thenSmpl_`
- extendSubst bndr (DoneEx arg)
+ extendSubst zapped_bndr (DoneEx arg)
(go fun args)
| otherwise
= tick (BetaReduction bndr) `thenSmpl_`
-- for the trivial bindings introduced by SimplUtils.mkRhsTyLam
preInlineUnconditionally bndr
= case getInlinePragma bndr of
- IMustBeINLINEd -> True
- ICanSafelyBeINLINEd InsideLam _ -> False
- ICanSafelyBeINLINEd not_in_lam True -> True -- Not inside a lambda,
+ IMustBeINLINEd -> True
+ ICanSafelyBeINLINEd NotInsideLam True -> True -- Not inside a lambda,
-- one occurrence ==> safe!
other -> False
-- from desugaring, with both a and b marked NOINLINE.
\end{code}
-\begin{code}
-inlineCase bndr scrut
- = exprIsTrivial scrut -- Duplication is free
- && ( isUnLiftedType (idType bndr)
- || scrut_is_evald_var -- So dropping the case won't change termination
- || isStrict (getIdDemandInfo bndr) -- It's going to get evaluated later, so again
- -- termination doesn't change
- || not opt_SimplPedanticBottoms) -- Or we don't care!
- where
- -- Check whether or not scrut is known to be evaluted
- -- It's not going to be a visible value (else the previous
- -- blob would apply) so we just check the variable case
- scrut_is_evald_var = case scrut of
- Var v -> isEvaldUnfolding (getIdUnfolding v)
- other -> False
-\end{code}
-
%************************************************************************
| conOkForAlt con -- Knocks out PrimOps and NoRepLits
= knownCon expr con args bndr alts se cont
--- Case of other value (e.g. a partial application or lambda)
--- Turn it back into a let
-rebuild scrut (Select _ bndr ((DEFAULT, bs, rhs):alts) se cont)
- | isUnLiftedType (idType bndr) && exprOkForSpeculation scrut
- || exprIsWHNF scrut
- = ASSERT( null bs && null alts )
- setSubstEnv se $
- simplBinder bndr $ \ bndr' ->
- completeBinding bndr bndr' scrut $
- simplExprF rhs cont
-
---------------------------------------------------------
-- The other Select cases
rebuild scrut (Select _ bndr alts se cont)
- | all (cheapEqExpr rhs1) other_rhss
- && inlineCase bndr scrut
- && all binders_unused alts
+ | -- Check that the RHSs are all the same, and
+ -- don't use the binders in the alternatives
+ -- This test succeeds rapidly in the common case of
+ -- a single DEFAULT alternative
+ all (cheapEqExpr rhs1) other_rhss && all binders_unused alts
+
+ -- Check that the scrutinee can be let-bound instead of case-bound
+ && ( (isUnLiftedType (idType bndr) && -- It's unlifted and floatable
+ exprOkForSpeculation scrut) -- NB: scrut = an unboxed variable satisfies
+ || is_a_value scrut -- It's a value
+
+-- || not opt_SimplPedanticBottoms) -- Or we don't care!
+-- We used to allow improving termination by discarding cases, unless -fpedantic-bottoms was on,
+-- but that breaks badly for the dataToTag# primop, which relies on a case to evaluate
+-- its argument: case x of { y -> dataToTag# y }
+-- 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
+ )
+
&& opt_SimplDoCaseElim
= -- Get rid of the case altogether
-- See the extensive notes on case-elimination below
-- Remember to bind the binder though!
- tick (CaseElim bndr) `thenSmpl_`
- setSubstEnv se (
- extendSubst bndr (DoneEx scrut) $
- simplExprF rhs1 cont
- )
+ tick (CaseElim bndr) `thenSmpl_` (
+ setSubstEnv se $
+ simplBinder bndr $ \ bndr' ->
+ completeBinding bndr bndr' scrut $
+ simplExprF rhs1 cont)
+
| otherwise
= rebuild_case scrut bndr alts se cont
where
(rhs1:other_rhss) = [rhs | (_,_,rhs) <- alts]
binders_unused (_, bndrs, _) = all isDeadBinder bndrs
+
+ -- Check whether or not scrut is known to be evaluted
+ is_a_value (Var v) = isEvaldUnfolding (getIdUnfolding v) -- It's been evaluated
+ || isStrict (getIdDemandInfo bndr) -- It's going to be evaluated later
+ is_a_value scrut = exprIsValue scrut
\end{code}
Case elimination [see the code above]
--
-- Now CPR should not w/w j because it's a thunk, so
-- that means that the enclosing function can't w/w either,
- -- which is a BIG LOSE. This actually happens in practice
+ -- which is a lose. Here's the example that happened in practice:
+ -- kgmod :: Int -> Int -> Int
+ -- kgmod x y = if x > 0 && y < 0 || x < 0 && y > 0
+ -- then 78
+ -- else 5
+
then newId realWorldStatePrimTy $ \ rw_id ->
returnSmpl ([rw_id], [Var realWorldPrimId])
else
`thenSmpl` \ (final_bndrs', final_args) ->
newId (foldr (mkFunTy . idType) rhs_ty' final_bndrs') $ \ join_bndr ->
- returnSmpl ([NonRec join_bndr (mkLams final_bndrs' rhs')],
+
+ -- Notice that we make the lambdas into one-shot-lambdas. The
+ -- join point is sure to be applied at most once, and doing so
+ -- prevents the body of the join point being floated out by
+ -- the full laziness pass
+ returnSmpl ([NonRec join_bndr (mkLams (map setOneShotLambda final_bndrs') rhs')],
(con, bndrs, mkApps (Var join_bndr) final_args))
\end{code}
import SimplUtils ( findDefault )
import CostCentre ( noCCS )
import Id ( Id, mkSysLocal, idType, getIdStrictness, idUnique, isExportedId,
- externallyVisibleId, setIdUnique, idName, getIdDemandInfo
+ externallyVisibleId, setIdUnique, idName, getIdDemandInfo, setIdType
)
import Var ( Var, varType, modifyIdInfo )
import IdInfo ( setDemandInfo, StrictnessInfo(..) )
returnUs (new_bind:floats, stg_body)
\end{code}
-Covert core @scc@ expression directly to STG @scc@ expression.
+Convert core @scc@ expression directly to STG @scc@ expression.
\begin{code}
coreExprToStgFloat env (Note (SCC cc) expr) dem
%* *
%************************************************************************
+Mangle cases involving seq# in the discriminant. Up to this
+point, seq# will appear like this:
+
+ case seq# e of
+ 0# -> seqError#
+ _ -> ...
+
+where the 0# branch is purely to bamboozle the strictness analyser
+This code comes from an unfolding for 'seq' in Prelude.hs. We
+translate this into
+
+ case e of
+ _ -> ...
+
+Now that the evaluation order is safe.
+
+This used to be done in the post-simplification phase, but we need
+unfoldings involving seq# to appear unmangled in the interface file,
+hence we do this mangling here.
+
+\begin{code}
+coreExprToStgFloat env
+ (Case scrut@(Con (PrimOp SeqOp) [Type ty, e]) bndr alts) dem
+ = coreExprToStgFloat env (Case e new_bndr [(DEFAULT,[],default_rhs)]) dem
+ where new_bndr = setIdType bndr ty
+ (other_alts, maybe_default) = findDefault alts
+ Just default_rhs = maybe_default
+\end{code}
+
+Now for normal case expressions...
+
\begin{code}
coreExprToStgFloat env (Case scrut bndr alts) dem
= coreExprToStgFloat env scrut (bdrDem bndr) `thenUs` \ (binds, scrut') ->
= getPprStyle $ \ sty ->
maybeParen ctxt_prec fUN_PREC $
if ifaceStyle sty then
- sep [ ptext SLIT("__forall") <+> brackets pp_tyvars <+> ptext SLIT("=>"), pp_body ]
+ sep [ ptext SLIT("__forall") <+> brackets pp_tyvars <+> ptext SLIT("=>"),
+ ppr_ty env tOP_PREC rho
+ ]
else
- sep [ ptext SLIT("forall") <+> pp_tyvars <> ptext SLIT("."), pp_body ]
+ -- The type checker occasionally prints a type in an error message,
+ -- and it had better come out looking like a user type
+ sep [ ptext SLIT("forall") <+> pp_tyvars <> ptext SLIT("."),
+ ppr_theta theta <+> ptext SLIT("=>"),
+ ppr_ty env tOP_PREC tau
+ ]
where
- (tyvars, body_ty) = splitForAllTys ty -- don't treat theta specially any more (KSW 1999-04)
+ (tyvars, rho) = splitForAllTys ty -- don't treat theta specially any more (KSW 1999-04)
+ (theta, tau) = splitRhoTy rho
pp_tyvars = hsep (map (pBndr env LambdaBind) tyvars)
- pp_body = ppr_ty env tOP_PREC body_ty
+ ppr_theta theta = parens (hsep (punctuate comma (map ppr_dict theta)))
+ ppr_dict (clas,tys) = ppr clas <+> hsep (map (ppr_ty env tYCON_PREC) tys)
+
ppr_ty env ctxt_prec (FunTy ty1 ty2)
= maybeParen ctxt_prec fUN_PREC (sep (ppr_ty env fUN_PREC ty1 : pp_rest ty2))
elemUFM,
filterUFM,
sizeUFM,
+ hashUFM,
isNullUFM,
lookupUFM, lookupUFM_Directly,
lookupWithDefaultUFM, lookupWithDefaultUFM_Directly,
filterUFM :: (elt -> Bool) -> UniqFM elt -> UniqFM elt
sizeUFM :: UniqFM elt -> Int
+hashUFM :: UniqFM elt -> Int
elemUFM :: Uniquable key => key -> UniqFM elt -> Bool
lookupUFM :: Uniquable key => UniqFM elt -> key -> Maybe elt
isNullUFM EmptyUFM = True
isNullUFM _ = False
+
+-- hashing is used in VarSet.uniqAway, and should be fast
+-- We use a cheap and cheerful method for now
+hashUFM EmptyUFM = 0
+hashUFM (NodeUFM n _ _ _) = IBOX(n)
+hashUFM (LeafUFM n _) = IBOX(n)
\end{code}
looking up in a hurry is the {\em whole point} of this binary tree lark.
unionUniqSets, unionManyUniqSets, minusUniqSet,
elementOfUniqSet, mapUniqSet, intersectUniqSets,
isEmptyUniqSet, filterUniqSet, sizeUniqSet, foldUniqSet,
- elemUniqSet_Directly, lookupUniqSet
+ elemUniqSet_Directly, lookupUniqSet, hashUniqSet
) where
#include "HsVersions.h"
sizeUniqSet :: UniqSet a -> Int
sizeUniqSet (MkUniqSet set) = sizeUFM set
+hashUniqSet :: UniqSet a -> Int
+hashUniqSet (MkUniqSet set) = hashUFM set
+
isEmptyUniqSet :: UniqSet a -> Bool
isEmptyUniqSet (MkUniqSet set) = isNullUFM set {-SLOW: sizeUFM set == 0-}
projects / ghc-hetmet.git / commitdiff