module VarEnv (
VarEnv, IdEnv, TyVarEnv,
emptyVarEnv, unitVarEnv, mkVarEnv,
- elemVarEnv, varEnvElts,
+ elemVarEnv, varEnvElts, varEnvKeys,
extendVarEnv, extendVarEnv_C, extendVarEnvList,
plusVarEnv, plusVarEnv_C,
delVarEnvList, delVarEnv,
InScopeSet, emptyInScopeSet, mkInScopeSet, delInScopeSet,
extendInScopeSet, extendInScopeSetList, modifyInScopeSet,
getInScopeVars, lookupInScope, elemInScopeSet, uniqAway,
+ mapInScopeSet,
-- RnEnv2 and its operations
RnEnv2, mkRnEnv2, rnBndr2, rnBndrs2, rnOccL, rnOccR, inRnEnvL, inRnEnvR,
delInScopeSet :: InScopeSet -> Var -> InScopeSet
delInScopeSet (InScope in_scope n) v = InScope (in_scope `delVarEnv` v) n
+mapInScopeSet :: (Var -> Var) -> InScopeSet -> InScopeSet
+mapInScopeSet f (InScope in_scope n) = InScope (mapVarEnv f in_scope) n
+
elemInScopeSet :: Var -> InScopeSet -> Bool
elemInScopeSet v (InScope in_scope n) = v `elemVarEnv` in_scope
mapVarEnv :: (a -> b) -> VarEnv a -> VarEnv b
modifyVarEnv :: (a -> a) -> VarEnv a -> Var -> VarEnv a
varEnvElts :: VarEnv a -> [a]
+varEnvKeys :: VarEnv a -> [Unique]
isEmptyVarEnv :: VarEnv a -> Bool
lookupVarEnv :: VarEnv a -> Var -> Maybe a
mkVarEnv = listToUFM
emptyVarEnv = emptyUFM
varEnvElts = eltsUFM
+varEnvKeys = keysUFM
unitVarEnv = unitUFM
isEmptyVarEnv = isNullUFM
foldVarEnv = foldUFM
SimplEnv, mkSimplEnv, extendIdSubst, extendTvSubst,
zapSubstEnv, setSubstEnv,
getInScope, setInScope, setInScopeSet, modifyInScope, addNewInScopeIds,
- getRules,
+ getRules, refineSimplEnv,
SimplSR(..), mkContEx, substId,
#include "HsVersions.h"
import SimplMonad
-import Rules ( RuleBase, emptyRuleBase )
-import Id ( Id, idType, idOccInfo, idInlinePragma, idUnfolding, setIdUnfolding )
+import Id ( Id, idType, idOccInfo, idUnfolding, setIdUnfolding )
import IdInfo ( IdInfo, vanillaIdInfo, occInfo, setOccInfo, specInfo, setSpecInfo,
arityInfo, setArityInfo, workerInfo, setWorkerInfo,
unfoldingInfo, setUnfoldingInfo,
unknownArity, workerExists
)
import CoreSyn
-import CoreUtils ( needsCaseBinding, exprIsTrivial )
+import Rules ( RuleBase )
+import CoreUtils ( needsCaseBinding )
import PprCore () -- Instances
import CostCentre ( CostCentreStack, subsumedCCS )
import Var
import VarEnv
-import VarSet ( isEmptyVarSet )
+import VarSet ( isEmptyVarSet, elemVarSetByKey, mkVarSet )
import OrdList
import qualified CoreSubst ( Subst, mkSubst, substExpr, substRules, substWorker )
import qualified Type ( substTy, substTyVarBndr )
-import Type ( Type, TvSubst(..), TvSubstEnv, isUnLiftedType, seqType, tyVarsOfType )
-import UniqSupply ( uniqsFromSupply, uniqFromSupply, splitUniqSupply,
- UniqSupply
- )
-import FiniteMap
-import BasicTypes ( TopLevelFlag, isTopLevel, isLoopBreaker,
- Activation, isActive, isAlwaysActive,
- OccInfo(..), isOneOcc, isFragileOcc
- )
-import CmdLineOpts ( SimplifierSwitch(..), SimplifierMode(..),
- DynFlags, DynFlag(..), dopt,
- opt_PprStyle_Debug, opt_HistorySize, opt_SimplNoPreInlining, opt_RulesOff
- )
-import Unique ( Unique )
+import Type ( Type, TvSubst(..), TvSubstEnv, composeTvSubst,
+ isUnLiftedType, seqType, tyVarsOfType )
+import BasicTypes ( OccInfo(..), isFragileOcc )
+import CmdLineOpts ( SimplifierMode(..) )
import Util ( mapAccumL )
import Outputable
-import FastTypes
-import FastString
-import Maybes ( expectJust )
-
-import GLAEXTS ( indexArray# )
-
-#if __GLASGOW_HASKELL__ < 503
-import PrelArr ( Array(..) )
-#else
-import GHC.Arr ( Array(..) )
-#endif
-
-import Array ( array, (//) )
-
\end{code}
%************************************************************************
getRules = seExtRules
\end{code}
+ GADT stuff
+
+Given an idempotent substitution, generated by the unifier, use it to
+refine the environment
+
+\begin{code}
+refineSimplEnv :: SimplEnv -> TvSubstEnv -> [OutTyVar] -> SimplEnv
+-- The TvSubstEnv is the refinement, and it refines OutTyVars into OutTypes
+refineSimplEnv env@(SimplEnv { seTvSubst = tv_subst, seInScope = in_scope })
+ refine_tv_subst tvs
+ = env { seTvSubst = composeTvSubst in_scope refine_tv_subst tv_subst,
+ seInScope = in_scope' }
+ where
+ in_scope'
+ | all bound_here (varEnvKeys refine_tv_subst) = in_scope
+ -- The tvs are the tyvars bound here. If only they
+ -- are refined, there's no need to do anything
+ | otherwise = mapInScopeSet refine_id in_scope
+
+ bound_here uniq = elemVarSetByKey uniq tv_set
+ tv_set = mkVarSet tvs
+
+ refine_id v -- Only refine its type; any rules will get
+ -- refined if they are used (I hope)
+ | isId v = setIdType v (Type.substTy refine_subst (idType v))
+ | otherwise = v
+ refine_subst = TvSubst in_scope refine_tv_subst
+\end{code}
%************************************************************************
%* *
refine v = case lookupInScope in_scope v of
Just v' -> v'
Nothing -> WARN( True, ppr v ) v -- This is an error!
-
\end{code}
simplBinder env bndr
| isTyVar bndr = do { let (env', tv) = substTyVarBndr env bndr
; seqTyVar tv `seq` return (env', tv) }
- | otherwise = do { let (env', id) = substIdBndr False env env bndr
+ | otherwise = do { let (env', id) = substIdBndr env bndr
; seqId id `seq` return (env', id) }
-------------
| otherwise = seqId id2 `seq` return (env', id2)
where
old_unf = idUnfolding bndr
- (env', id1) = substIdBndr False env env bndr
+ (env', id1) = substIdBndr env bndr
id2 = id1 `setIdUnfolding` substUnfolding env old_unf
-------------
\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.
-
-substBndr :: SimplEnv -> Var -> (SimplEnv, Var)
-substBndr subst bndr
- | isTyVar bndr = substTyVarBndr subst bndr
- | otherwise = substIdBndr True {- keep fragile info -} subst subst bndr
-
-substBndrs :: SimplEnv -> [Var] -> (SimplEnv, [Var])
-substBndrs subst bndrs = mapAccumL substBndr subst bndrs
-
-substRecBndrs :: SimplEnv -> [Id] -> (SimplEnv, [Id])
--- Substitute a mutually recursive group
-substRecBndrs subst bndrs
- = (new_subst, new_bndrs)
- where
- -- Here's the reason we need to pass rec_subst to substIdBndr
- (new_subst, new_bndrs) = mapAccumL (substIdBndr True {- keep fragile info -} new_subst)
- subst bndrs
-\end{code}
-
-
-\begin{code}
-substIdBndr :: Bool -- True <=> keep fragile info
- -> SimplEnv -- Substitution to use for the IdInfo
- -> SimplEnv -> Id -- Substitition and Id to transform
- -> (SimplEnv, Id) -- Transformed pair
+substIdBndr :: SimplEnv -> Id -- Substitition and Id to transform
+ -> (SimplEnv, 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
+-- * Fragile occurrence info zapped
-- * 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
-substIdBndr keep_fragile rec_env
- env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst})
+substIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst})
old_id
= (env { seInScope = in_scope `extendInScopeSet` new_id,
seIdSubst = new_subst }, new_id)
-- new_id has the right IdInfo
-- The lazy-set is because we're in a loop here, with
-- rec_env, when dealing with a mutually-recursive group
- new_id = maybeModifyIdInfo (substIdInfo keep_fragile rec_env) id2
+ new_id = maybeModifyIdInfo (substIdInfo env) id2
-- Extend the substitution if the unique has changed
-- See the notes with substTyVarBndr for the delSubstEnv
-- Used by the simplifier to compute new IdInfo for a let(rec) binder,
-- subsequent to simplLetId having zapped its IdInfo
simplIdInfo env old_info
- = case substIdInfo False env old_info of
+ = case substIdInfo env old_info of
Just new_info -> new_info
Nothing -> old_info
-substIdInfo :: Bool -- True <=> keep even fragile info
- -> SimplEnv
+substIdInfo :: SimplEnv
-> IdInfo
-> Maybe IdInfo
--- The keep_fragile flag is True when we are running a simple expression
--- substitution that preserves all structure, so that arity and occurrence
--- info are unaffected. The False state is used more often.
---
-- Substitute the
-- rules
-- worker info
-- Zap the unfolding
--- If keep_fragile then
--- keep OccInfo
--- keep Arity
--- else
--- keep only 'robust' OccInfo
--- zap Arity
+-- Keep only 'robust' OccInfo
+-- Zap Arity
--
-- Seq'ing on the returned IdInfo is enough to cause all the
-- substitutions to happen completely
-substIdInfo keep_fragile env info
+substIdInfo env info
| nothing_to_do = Nothing
| otherwise = Just (info `setOccInfo` (if keep_occ then old_occ else NoOccInfo)
`setArityInfo` (if keep_arity then old_arity else unknownArity)
not (workerExists old_wrkr) &&
not (hasUnfolding (unfoldingInfo info))
- keep_occ = keep_fragile || not (isFragileOcc old_occ)
- keep_arity = keep_fragile || old_arity == unknownArity
+ keep_occ = not (isFragileOcc old_occ)
+ keep_arity = old_arity == unknownArity
old_arity = arityInfo info
old_occ = occInfo info
old_rules = specInfo info
projects / ghc-hetmet.git / commitdiff