Commit 09518039 authored by simonpj's avatar simonpj

[project @ 2001-03-01 17:10:06 by simonpj]

Improve IdInfo substitution

To get rules to work nicely, we need to make rules for recursive functions
active in the RHS of the very recursive function itself.  This can be
done nicely: the change is to move the calls to simplIdInfo in Simplify
to an earlier place.

The second thing is that when doing simple expression substitution
in a rule (which we do during simplification for rules attached to an Id)
we were zapping the occurrence info carefully pinned on the rule binders
when the rule was put into the Id's rules.  This in turn meant that
the simplifer ran more iterations than necessary when rules were fired.
(Andrew Tolmach discovered this.)

So I tidied up the interface to Subst a little.  The relevant functions
that have changed are
	simplBndr, simplBndrs, simplLetId, simplIdInfo,
	substAndCloneId, substAndCloneIds, substAndCloneRecIds,

There are consequential changes in other modules, but it compiles
at least the whole standard libraries happily, and the codegen tests,
so I'm reasonably confident in it.  But watch out for new strange
happenings.
parent 75e81ca4
......@@ -19,7 +19,7 @@ module Id (
-- Modifying an Id
setIdName, setIdUnique, setIdType, setIdNoDiscard,
setIdInfo, lazySetIdInfo, modifyIdInfo, maybeModifyIdInfo,
zapFragileIdInfo, zapLamIdInfo,
zapLamIdInfo, zapDemandIdInfo,
-- Predicates
isImplicitId, isDeadBinder,
......@@ -458,10 +458,8 @@ clearOneShotLambda id
\end{code}
\begin{code}
zapFragileIdInfo :: Id -> Id
zapFragileIdInfo id = maybeModifyIdInfo zapFragileInfo id
zapLamIdInfo :: Id -> Id
zapLamIdInfo id = maybeModifyIdInfo zapLamInfo id
\end{code}
zapDemandIdInfo id = maybeModifyIdInfo zapDemandInfo id
\end{code}
......@@ -13,7 +13,8 @@ module IdInfo (
vanillaIdInfo, constantIdInfo, mkIdInfo, seqIdInfo, megaSeqIdInfo,
-- Zapping
zapFragileInfo, zapLamInfo, zapSpecPragInfo, shortableIdInfo, copyIdInfo,
zapLamInfo, zapDemandInfo,
zapSpecPragInfo, shortableIdInfo, copyIdInfo,
-- Flavour
IdFlavour(..), flavourInfo, makeConstantFlavour,
......@@ -66,7 +67,7 @@ module IdInfo (
CprInfo(..), cprInfo, setCprInfo, ppCprInfo, noCprInfo,
-- Lambda-bound variable info
LBVarInfo(..), lbvarInfo, setLBVarInfo, noLBVarInfo
LBVarInfo(..), lbvarInfo, setLBVarInfo, noLBVarInfo, hasNoLBVarInfo
) where
#include "HsVersions.h"
......@@ -633,6 +634,9 @@ seqLBVar l = l `seq` ()
\end{code}
\begin{code}
hasNoLBVarInfo NoLBVarInfo = True
hasNoLBVarInfo other = False
noLBVarInfo = NoLBVarInfo
-- not safe to print or parse LBVarInfo because it is not really a
......@@ -660,58 +664,6 @@ instance Show LBVarInfo where
%* *
%************************************************************************
zapFragileInfo is used when cloning binders, mainly in the
simplifier. We must forget about used-once information because that
isn't necessarily correct in the transformed program.
Also forget specialisations and unfoldings because they would need
substitution to be correct. (They get pinned back on separately.)
Hoever, we REMEMBER loop-breaker and dead-variable information. The loop-breaker
information is used (for example) in MkIface to avoid exposing the unfolding of
a loop breaker.
\begin{code}
zapFragileInfo :: IdInfo -> Maybe IdInfo
zapFragileInfo info@(IdInfo {occInfo = occ,
workerInfo = wrkr,
specInfo = rules,
unfoldingInfo = unfolding})
| not (isFragileOcc occ)
-- We must forget about whether it was marked safe-to-inline,
-- because that isn't necessarily true in the simplified expression.
-- This is important because expressions may be re-simplified
-- We don't zap deadness or loop-breaker-ness.
-- The latter is important because it tells MkIface not to
-- spit out an inlining for the thing. The former doesn't
-- seem so important, but there's no harm.
&& isEmptyCoreRules rules
-- Specialisations would need substituting. They get pinned
-- back on separately.
&& not (workerExists wrkr)
&& not (hasUnfolding unfolding)
-- This is very important; occasionally a let-bound binder is used
-- as a binder in some lambda, in which case its unfolding is utterly
-- bogus. Also the unfolding uses old binders so if we left it we'd
-- have to substitute it. Much better simply to give the Id a new
-- unfolding each time, which is what the simplifier does.
= Nothing
| otherwise
= Just (info {occInfo = robust_occ_info,
workerInfo = noWorkerInfo,
specInfo = emptyCoreRules,
unfoldingInfo = noUnfolding})
where
-- It's important to keep the loop-breaker info,
-- because the substitution doesn't remember it.
robust_occ_info = case occ of
OneOcc _ _ -> NoOccInfo
other -> occ
\end{code}
@zapLamInfo@ is used for lambda binders that turn out to to be
part of an unsaturated lambda
......@@ -735,6 +687,13 @@ zapLamInfo info@(IdInfo {occInfo = occ, demandInfo = demand})
other -> occ
\end{code}
\begin{code}
zapDemandInfo :: IdInfo -> Maybe IdInfo
zapDemandInfo info@(IdInfo {demandInfo = demand})
| not (isStrict demand) = Nothing
| otherwise = Just (info {demandInfo = wwLazy})
\end{code}
copyIdInfo is used when shorting out a top-level binding
f_local = BIG
......
......@@ -23,8 +23,8 @@ module Subst (
bindSubst, unBindSubst, bindSubstList, unBindSubstList,
-- Binders
substBndr, substBndrs, substTyVar, substId, substIds,
substAndCloneId, substAndCloneIds,
simplBndr, simplBndrs, simplLetId, simplIdInfo,
substAndCloneId, substAndCloneIds, substAndCloneRecIds,
-- Type stuff
mkTyVarSubst, mkTopTyVarSubst,
......@@ -39,7 +39,7 @@ module Subst (
import CmdLineOpts ( opt_PprStyle_Debug )
import CoreSyn ( Expr(..), Bind(..), Note(..), CoreExpr,
CoreRules(..), CoreRule(..),
isEmptyCoreRules, seqRules
isEmptyCoreRules, seqRules, hasUnfolding, noUnfolding
)
import CoreFVs ( exprFreeVars, mustHaveLocalBinding )
import TypeRep ( Type(..), TyNote(..) ) -- friend
......@@ -49,15 +49,19 @@ import Type ( ThetaType, PredType(..), ClassContext,
import VarSet
import VarEnv
import Var ( setVarUnique, isId )
import Id ( idType, setIdType, idOccInfo, zapFragileIdInfo, maybeModifyIdInfo )
import IdInfo ( IdInfo, isFragileOcc,
specInfo, setSpecInfo,
import Id ( idType, idInfo, setIdInfo, setIdType, idOccInfo, maybeModifyIdInfo )
import IdInfo ( IdInfo, mkIdInfo,
occInfo, isFragileOcc, setOccInfo,
specInfo, setSpecInfo, flavourInfo,
unfoldingInfo, setUnfoldingInfo,
CafInfo(NoCafRefs),
WorkerInfo(..), workerExists, workerInfo, setWorkerInfo, WorkerInfo,
lbvarInfo, LBVarInfo(..), setLBVarInfo
lbvarInfo, LBVarInfo(..), setLBVarInfo, hasNoLBVarInfo
)
import Unique ( Uniquable(..), deriveUnique )
import BasicTypes ( OccInfo(..) )
import Unique ( Unique, Uniquable(..), deriveUnique )
import UniqSet ( elemUniqSet_Directly )
import UniqSupply ( UniqSupply, uniqFromSupply, splitUniqSupply )
import UniqSupply ( UniqSupply, uniqFromSupply, uniqsFromSupply )
import Var ( Var, Id, TyVar, isTyVar )
import Outputable
import PprCore () -- Instances
......@@ -189,9 +193,7 @@ type IdSubst = Subst
The general plan about the substitution and in-scope set for Ids is as follows
* substId always adds new_id to the in-scope set.
new_id has a correctly-substituted type, but all its fragile IdInfo has been zapped.
That is added back in later. So new_id is the minimal thing it's
correct to substitute.
new_id has a correctly-substituted type, occ info
* substId adds a binding (DoneId new_id occ) to the substitution if
EITHER the Id's unique has changed
......@@ -508,7 +510,7 @@ substExpr subst expr
go (Let (Rec pairs) body) = Let (Rec pairs') (substExpr subst' body)
where
(subst', bndrs') = substBndrs subst (map fst pairs)
(subst', bndrs') = substRecIds subst (map fst pairs)
pairs' = bndrs' `zip` rhss'
rhss' = map (substExpr subst' . snd) pairs
......@@ -527,87 +529,160 @@ substExpr subst expr
\end{code}
Substituting in binders is a rather tricky part of the whole compiler.
When we hit a binder we may need to
(a) apply the the type envt (if non-empty) to its type
(c) give it a new unique to avoid name clashes
%************************************************************************
%* *
\section{Substituting an Id binder}
%* *
%************************************************************************
\begin{code}
-- simplBndr and simplLetId are used by the simplifier
simplBndr :: Subst -> Var -> (Subst, Var)
-- Used for lambda and case-bound variables
-- Clone Id if necessary, substitute type
-- Return with IdInfo already substituted,
-- but occurrence info zapped
-- The substitution is extended only if the variable is cloned, because
-- we don't need to use it to track occurrence info.
simplBndr subst bndr
| isTyVar bndr = substTyVar subst bndr
| otherwise = subst_id isFragileOcc subst subst bndr
simplBndrs :: Subst -> [Var] -> (Subst, [Var])
simplBndrs subst bndrs = mapAccumL simplBndr subst bndrs
simplLetId :: Subst -> Id -> (Subst, Id)
-- Clone Id if necessary
-- Substitute its type
-- Return an Id with completely zapped IdInfo
-- Augment the subtitution if the unique changed or if there's
-- interesting occurrence info
-- [A subsequent substIdInfo will restore its IdInfo]
simplLetId subst@(Subst in_scope env) old_id
= (Subst (in_scope `extendInScopeSet` new_id) new_env, new_id)
where
old_info = idInfo old_id
id1 = uniqAway in_scope old_id
id2 = substIdType subst id1
new_id = id2 `setIdInfo` mkIdInfo (flavourInfo old_info) NoCafRefs
-- Zap the IdIno altogether, but preserve the flavour
-- Extend the substitution if the unique has changed,
-- or there's some useful occurrence information
-- See the notes with substTyVar for the delSubstEnv
occ_info = occInfo old_info
new_env | new_id /= old_id || isFragileOcc occ_info
= extendSubstEnv env old_id (DoneId new_id occ_info)
| otherwise
= delSubstEnv env old_id
simplIdInfo :: Subst -> IdInfo -> Id -> Id
-- Used by the simplifier to compute new IdInfo for a let(rec) binder,
-- subsequent to simplLetId having zapped its IdInfo
simplIdInfo subst old_info bndr
= case substIdInfo subst isFragileOcc old_info of
Just new_info -> bndr `setIdInfo` new_info
Nothing -> bndr `setIdInfo` old_info
\end{code}
\begin{code}
-- substBndr and friends are used when doing expression substitution only
-- In this case we can preserve occurrence information, and indeed we want
-- to do so else lose useful occ info in rules. Hence the calls to
-- simpl_id with keepOccInfo
substBndr :: Subst -> Var -> (Subst, Var)
substBndr subst bndr
| isTyVar bndr = substTyVar subst bndr
| otherwise = substId subst bndr
| otherwise = subst_id keepOccInfo subst subst bndr
substBndrs :: Subst -> [Var] -> (Subst, [Var])
substBndrs subst bndrs = mapAccumL substBndr subst bndrs
substRecIds :: Subst -> [Id] -> (Subst, [Id])
-- Substitute a mutually recursive group
substRecIds subst bndrs
= (new_subst, new_bndrs)
where
-- Here's the reason we need to pass rec_subst to subst_id
(new_subst, new_bndrs) = mapAccumL (subst_id keepOccInfo new_subst) subst bndrs
substIds :: Subst -> [Id] -> (Subst, [Id])
substIds subst bndrs = mapAccumL substId subst bndrs
keepOccInfo occ = False -- Never fragile
\end{code}
substId :: Subst -> Id -> (Subst, Id)
-- Returns an Id with empty IdInfo
-- See the notes with the Subst data type decl at the
-- top of this module
substId subst@(Subst in_scope env) old_id
\begin{code}
subst_id :: (OccInfo -> Bool) -- True <=> the OccInfo is fragile
-> Subst -- Substitution to use for the IdInfo
-> Subst -> Id -- Substitition and Id to transform
-> (Subst, Id) -- Transformed pair
-- Returns with:
-- * Unique changed if necessary
-- * Type substituted
-- * Unfolding zapped
-- * Rules, worker, lbvar info all substituted
-- * Occurrence info zapped if is_fragile_occ returns True
-- * The in-scope set extended with the returned Id
-- * The substitution extended with a DoneId if unique changed
-- In this case, the var in the DoneId is the same as the
-- var returned
subst_id is_fragile_occ rec_subst subst@(Subst in_scope env) old_id
= (Subst (in_scope `extendInScopeSet` new_id) new_env, new_id)
where
id_ty = idType old_id
occ_info = idOccInfo old_id
-- id1 has its type zapped
id1 | noTypeSubst env
|| isEmptyVarSet (tyVarsOfType id_ty) = old_id
-- The tyVarsOfType is cheaper than it looks
-- because we cache the free tyvars of the type
-- in a Note in the id's type itself
| otherwise = setIdType old_id (substTy subst id_ty)
-- id2 has its IdInfo zapped
id2 = zapFragileIdInfo id1
-- id3 has its LBVarInfo zapped
id3 = maybeModifyIdInfo (\ info -> go info (lbvarInfo info)) id2
where go info (LBVarInfo u@(TyVarTy _)) = Just $ setLBVarInfo info $
LBVarInfo (subst_ty subst u)
go info _ = Nothing
-- new_id is cloned if necessary
new_id = uniqAway in_scope id3
-- Extend the substitution if the unique has changed,
-- or there's some useful occurrence information
-- id1 is cloned if necessary
id1 = uniqAway in_scope old_id
-- id2 has its type zapped
id2 = substIdType subst id1
-- new_id has the right IdInfo
-- The lazy-set is because we're in a loop here, with
-- rec_subst, when dealing with a mutually-recursive group
new_id = maybeModifyIdInfo (substIdInfo rec_subst is_fragile_occ) id2
-- Extend the substitution if the unique has changed
-- See the notes with substTyVar for the delSubstEnv
new_env | new_id /= old_id || isFragileOcc occ_info
= extendSubstEnv env old_id (DoneId new_id occ_info)
new_env | new_id /= old_id
= extendSubstEnv env old_id (DoneId new_id (idOccInfo old_id))
| otherwise
= delSubstEnv env old_id
\end{code}
Now a variant that unconditionally allocates a new unique.
It also unconditionally zaps the OccInfo.
\begin{code}
substAndCloneIds :: Subst -> UniqSupply -> [Id] -> (Subst, UniqSupply, [Id])
substAndCloneIds subst us [] = (subst, us, [])
substAndCloneIds subst us (b:bs) = case substAndCloneId subst us b of { (subst1, us1, b') ->
case substAndCloneIds subst1 us1 bs of { (subst2, us2, bs') ->
(subst2, us2, (b':bs')) }}
substAndCloneId :: Subst -> UniqSupply -> Id -> (Subst, UniqSupply, Id)
substAndCloneId subst@(Subst in_scope env) us old_id
= (Subst (in_scope `extendInScopeSet` new_id)
(extendSubstEnv env old_id (DoneEx (Var new_id))),
new_us,
new_id)
subst_clone_id :: Subst -- Substitution to use (lazily) for the rules and worker
-> Subst -> (Id, Unique) -- Substitition and Id to transform
-> (Subst, Id) -- Transformed pair
subst_clone_id rec_subst subst@(Subst in_scope env) (old_id, uniq)
= (Subst (in_scope `extendInScopeSet` new_id) new_env, new_id)
where
id1 = setVarUnique old_id uniq
id2 = substIdType subst id1
new_id = maybeModifyIdInfo (substIdInfo rec_subst isFragileOcc) id2
new_env = extendSubstEnv env old_id (DoneId new_id NoOccInfo)
substAndCloneIds :: Subst -> UniqSupply -> [Id] -> (Subst, [Id])
substAndCloneIds subst us ids
= mapAccumL (subst_clone_id subst) subst (ids `zip` uniqsFromSupply (length ids) us)
substAndCloneRecIds :: Subst -> UniqSupply -> [Id] -> (Subst, [Id])
substAndCloneRecIds subst us ids
= (subst', ids')
where
id_ty = idType old_id
id1 | noTypeSubst env || isEmptyVarSet (tyVarsOfType id_ty) = old_id
| otherwise = setIdType old_id (substTy subst id_ty)
(subst', ids') = mapAccumL (subst_clone_id subst') subst
(ids `zip` uniqsFromSupply (length ids) us)
id2 = zapFragileIdInfo id1
new_id = setVarUnique id2 (uniqFromSupply us1)
(us1,new_us) = splitUniqSupply us
substAndCloneId :: Subst -> UniqSupply -> Id -> (Subst, Id)
substAndCloneId subst@(Subst in_scope env) us old_id
= subst_clone_id subst subst (old_id, uniqFromSupply us)
\end{code}
......@@ -619,29 +694,50 @@ substAndCloneId subst@(Subst in_scope env) us old_id
\begin{code}
substIdInfo :: Subst
-> IdInfo -- Get un-substituted ones from here
-> IdInfo -- Substitute it and add it to here
-> IdInfo -- To give this
-- Seq'ing on the returned IdInfo is enough to cause all the
-- substitutions to happen completely
substIdInfo subst old_info new_info
= info2
where
info1 | isEmptyCoreRules old_rules = new_info
| otherwise = new_info `setSpecInfo` new_rules
-> (OccInfo -> Bool) -- True <=> zap the occurrence info
-> IdInfo
-> Maybe IdInfo
-- Substitute the
-- rules
-- worker info
-- LBVar info
-- Zap the unfolding
-- Zap the occ info if instructed to do so
--
-- Seq'ing on the returned IdInfo is enough to cause all the
-- substitutions to happen completely
substIdInfo subst is_fragile_occ info
| nothing_to_do = Nothing
| otherwise = Just (info `setOccInfo` (if zap_occ then NoOccInfo else old_occ)
`setSpecInfo` substRules subst old_rules
`setWorkerInfo` substWorker subst old_wrkr
`setLBVarInfo` substLBVar subst old_lbv
`setUnfoldingInfo` noUnfolding)
-- setSpecInfo does a seq
where
new_rules = substRules subst old_rules
info2 | not (workerExists old_wrkr) = info1
| otherwise = info1 `setWorkerInfo` new_wrkr
-- setWorkerInfo does a seq
where
new_wrkr = substWorker subst old_wrkr
old_rules = specInfo old_info
old_wrkr = workerInfo old_info
where
nothing_to_do = not zap_occ &&
isEmptyCoreRules old_rules &&
not (workerExists old_wrkr) &&
hasNoLBVarInfo old_lbv &&
not (hasUnfolding (unfoldingInfo info))
zap_occ = is_fragile_occ old_occ
old_occ = occInfo info
old_rules = specInfo info
old_wrkr = workerInfo info
old_lbv = lbvarInfo info
substIdType :: Subst -> Id -> Id
substIdType subst@(Subst in_scope env) id
| noTypeSubst env || isEmptyVarSet (tyVarsOfType old_ty) = id
| otherwise = setIdType id (substTy subst old_ty)
-- The tyVarsOfType is cheaper than it looks
-- because we cache the free tyvars of the type
-- in a Note in the id's type itself
where
old_ty = idType id
substWorker :: Subst -> WorkerInfo -> WorkerInfo
-- Seq'ing on the returned WorkerInfo is enough to cause all the
......@@ -686,4 +782,9 @@ substVarSet subst fvs
DoneEx expr -> exprFreeVars expr
DoneTy ty -> tyVarsOfType ty
ContEx se' expr -> substVarSet (setSubstEnv subst se') (exprFreeVars expr)
substLBVar subst NoLBVarInfo = NoLBVarInfo
substLBVar subst (LBVarInfo ty) = ty1 `seq` LBVarInfo ty1
where
ty1 = substTy subst ty
\end{code}
This diff is collapsed.
......@@ -5,7 +5,7 @@
\begin{code}
module SimplUtils (
simplBinder, simplBinders, simplIds,
simplBinder, simplBinders, simplRecIds, simplLetId,
tryRhsTyLam, tryEtaExpansion,
mkCase,
......@@ -25,9 +25,10 @@ import CmdLineOpts ( switchIsOn, SimplifierSwitch(..),
import CoreSyn
import CoreUtils ( exprIsTrivial, cheapEqExpr, exprType, exprIsCheap,
etaExpand, exprEtaExpandArity, bindNonRec, mkCoerce,
findDefault, findAlt
findDefault
)
import Subst ( InScopeSet, mkSubst, substBndrs, substBndr, substIds, substExpr )
import Subst ( InScopeSet, mkSubst, substExpr )
import qualified Subst ( simplBndrs, simplBndr, simplLetId )
import Id ( idType, idName,
idUnfolding, idStrictness,
mkVanillaId, idInfo
......@@ -45,7 +46,7 @@ import Type ( Type, mkForAllTys, seqType, repType,
import TyCon ( tyConDataConsIfAvailable )
import DataCon ( dataConRepArity )
import VarEnv ( SubstEnv )
import Util ( lengthExceeds )
import Util ( lengthExceeds, mapAccumL )
import Outputable
\end{code}
......@@ -428,7 +429,7 @@ simplBinders :: [InBinder] -> ([OutBinder] -> SimplM a) -> SimplM a
simplBinders bndrs thing_inside
= getSubst `thenSmpl` \ subst ->
let
(subst', bndrs') = substBndrs subst bndrs
(subst', bndrs') = Subst.simplBndrs subst bndrs
in
seqBndrs bndrs' `seq`
setSubst subst' (thing_inside bndrs')
......@@ -437,23 +438,29 @@ simplBinder :: InBinder -> (OutBinder -> SimplM a) -> SimplM a
simplBinder bndr thing_inside
= getSubst `thenSmpl` \ subst ->
let
(subst', bndr') = substBndr subst bndr
(subst', bndr') = Subst.simplBndr subst bndr
in
seqBndr bndr' `seq`
setSubst subst' (thing_inside bndr')
-- Same semantics as simplBinders, but a little less
-- plumbing and hence a little more efficient.
-- Maybe not worth the candle?
simplIds :: [InBinder] -> ([OutBinder] -> SimplM a) -> SimplM a
simplIds ids thing_inside
simplRecIds :: [InBinder] -> ([OutBinder] -> SimplM a) -> SimplM a
simplRecIds ids thing_inside
= getSubst `thenSmpl` \ subst ->
let
(subst', bndrs') = substIds subst ids
(subst', ids') = mapAccumL Subst.simplLetId subst ids
in
seqBndrs bndrs' `seq`
setSubst subst' (thing_inside bndrs')
seqBndrs ids' `seq`
setSubst subst' (thing_inside ids')
simplLetId :: InBinder -> (OutBinder -> SimplM a) -> SimplM a
simplLetId id thing_inside
= getSubst `thenSmpl` \ subst ->
let
(subst', id') = Subst.simplLetId subst id
in
seqBndr id' `seq`
setSubst subst' (thing_inside id')
seqBndrs [] = ()
seqBndrs (b:bs) = seqBndr b `seq` seqBndrs bs
......
......@@ -15,7 +15,7 @@ import CmdLineOpts ( switchIsOn, opt_SimplDoEtaReduction,
)
import SimplMonad
import SimplUtils ( mkCase, tryRhsTyLam, tryEtaExpansion,
simplBinder, simplBinders, simplIds,
simplBinder, simplBinders, simplRecIds, simplLetId,
SimplCont(..), DupFlag(..), mkStop, mkRhsStop,
contResultType, discardInline, countArgs, contIsDupable,
getContArgs, interestingCallContext, interestingArg, isStrictType
......@@ -55,8 +55,8 @@ import Type ( mkTyVarTys, isUnLiftedType, seqType,
mkFunTy, splitTyConApp_maybe, tyConAppArgs,
funResultTy
)
import Subst ( mkSubst, substTy,
isInScope, lookupIdSubst, substIdInfo
import Subst ( mkSubst, substTy, substEnv,
isInScope, lookupIdSubst, simplIdInfo
)
import TyCon ( isDataTyCon, tyConDataConsIfAvailable )
import TysPrim ( realWorldStatePrimTy )
......@@ -96,7 +96,7 @@ simplTopBinds binds
-- so that if a transformation rule has unexpectedly brought
-- anything into scope, then we don't get a complaint about that.
-- It's rather as if the top-level binders were imported.
simplIds (bindersOfBinds binds) $ \ bndrs' ->
simplRecIds (bindersOfBinds binds) $ \ bndrs' ->
simpl_binds binds bndrs' `thenSmpl` \ (binds', _) ->
freeTick SimplifierDone `thenSmpl_`
returnSmpl (fromOL binds')
......@@ -217,7 +217,7 @@ simplExprF (Case scrut bndr alts) cont
simplExprF (Let (Rec pairs) body) cont
= simplIds (map fst pairs) $ \ bndrs' ->
= simplRecIds (map fst pairs) $ \ bndrs' ->
-- NB: bndrs' don't have unfoldings or spec-envs
-- We add them as we go down, using simplPrags
......@@ -303,10 +303,10 @@ simplExprF (Note InlineMe e) cont
keep_inline (ArgOf _ _ _) = True -- about this predicate
keep_inline other = False
-- A non-recursive let is dealt with by simplBeta
-- A non-recursive let is dealt with by simplNonRecBind
simplExprF (Let (NonRec bndr rhs) body) cont
= getSubstEnv `thenSmpl` \ se ->
simplBeta bndr rhs se (contResultType cont) $
simplNonRecBind bndr rhs se (contResultType cont) $
simplExprF body cont
\end{code}
......@@ -331,7 +331,7 @@ simplLam fun cont
-- Ordinary beta reduction
go (Lam bndr body) cont@(ApplyTo _ arg arg_se body_cont)
= tick (BetaReduction bndr) `thenSmpl_`
simplBeta zapped_bndr arg arg_se cont_ty
simplNonRecBind zapped_bndr arg arg_se cont_ty
(go body body_cont)
where
zapped_bndr = zap_it bndr
......@@ -416,42 +416,53 @@ simplType ty
%* *
%************************************************************************
@simplBeta@ is used for non-recursive lets in expressions,
@simplNonRecBind@ is used for non-recursive lets in expressions,
as well as true beta reduction.
Very similar to @simplLazyBind@, but not quite the same.
\begin{code}
simplBeta :: InId -- Binder
simplNonRecBind :: InId -- Binder
-> InExpr -> SubstEnv -- Arg, with its subst-env
-> OutType -- Type of thing computed by the context
-> SimplM OutExprStuff -- The body
-> SimplM OutExprStuff
#ifdef DEBUG
simplBeta bndr rhs rhs_se cont_ty thing_inside
simplNonRecBind bndr rhs rhs_se cont_ty thing_inside
| isTyVar bndr
= pprPanic "simplBeta" (ppr bndr <+> ppr rhs)
= pprPanic "simplNonRecBind" (ppr bndr <+> ppr rhs)
#endif
simplBeta bndr rhs rhs_se cont_ty thing_inside
simplNonRecBind bndr rhs rhs_se cont_ty thing_inside
| preInlineUnconditionally False {- not black listed -} bndr
= tick (PreInlineUnconditionally bndr) `thenSmpl_`
extendSubst bndr (ContEx rhs_se rhs) thing_inside
| otherwise
= -- Simplify the RHS
simplBinder bndr $ \ bndr' ->
= -- Simplify the binder.
-- Don't use simplBinder because that doesn't keep
-- fragile occurrence in the substitution
simplLetId bndr $ \ bndr' ->
getSubst `thenSmpl` \ bndr_subst ->
let
-- Substitute its IdInfo (which simplLetId does not)
-- The appropriate substitution env is the one right here,
-- not rhs_se. Often they are the same, when all this
-- has arisen from an application (\x. E) RHS, perhaps they aren't
bndr'' = simplIdInfo bndr_subst (idInfo bndr) bndr'
bndr_ty' = idType bndr'
is_strict = isStrict (idDemandInfo bndr) || isStrictType bndr_ty'
in
modifyInScope bndr'' bndr'' $
-- Simplify the argument
simplValArg bndr_ty' is_strict rhs rhs_se cont_ty $ \ rhs' ->