X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FSimplMonad.lhs;h=bc09e1128ce96c8dbc97fa159b21b3e52e003aa8;hb=28a464a75e14cece5db40f2765a29348273ff2d2;hp=19faf99852b1e658eced56d9fd919dcac48e9cc1;hpb=b4775e5e760111e2d71fba3c44882dce390edfb2;p=ghc-hetmet.git diff --git a/ghc/compiler/simplCore/SimplMonad.lhs b/ghc/compiler/simplCore/SimplMonad.lhs index 19faf99..bc09e11 100644 --- a/ghc/compiler/simplCore/SimplMonad.lhs +++ b/ghc/compiler/simplCore/SimplMonad.lhs @@ -5,22 +5,14 @@ \begin{code} module SimplMonad ( - InId, InBind, InExpr, InAlt, InArg, InType, InBinder, - OutId, OutBind, OutExpr, OutAlt, OutArg, OutType, OutBinder, - OutExprStuff, OutStuff, returnOutStuff, - -- The monad SimplM, initSmpl, returnSmpl, thenSmpl, thenSmpl_, mapSmpl, mapAndUnzipSmpl, mapAccumLSmpl, getDOptsSmpl, - -- The inlining black-list - setBlackList, getBlackList, noInlineBlackList, - -- Unique supply - getUniqueSmpl, getUniquesSmpl, getUniqSupplySmpl, - newId, newIds, + getUniqueSmpl, getUniquesSmpl, getUniqSupplySmpl, newId, -- Counting SimplCount, Tick(..), @@ -29,141 +21,39 @@ module SimplMonad ( plusSimplCount, isZeroSimplCount, -- Switch checker - SwitchChecker, getSwitchChecker, getSimplIntSwitch, - - -- Cost centres - getEnclosingCC, setEnclosingCC, - - -- Environments - getEnv, setAllExceptInScope, - getSubst, setSubst, - getSubstEnv, extendSubst, extendSubstList, - getInScope, setInScope, modifyInScope, addNewInScopeIds, - setSubstEnv, zapSubstEnv, - getSimplBinderStuff, setSimplBinderStuff, - - -- Adding bindings - addLetBind, addLetBinds, addAuxiliaryBind, addAuxiliaryBinds, - addCaseBind, needsCaseBinding, addNonRecBind, wrapFloats, addFloats + SwitchChecker, SwitchResult(..), getSimplIntSwitch, + isAmongSimpl, intSwitchSet, switchIsOn ) where #include "HsVersions.h" -import Id ( Id, mkSysLocal, idType, idUnfolding, isDataConWrapId ) -import CoreSyn -import CoreUnfold ( isCompulsoryUnfolding ) -import CoreUtils ( exprOkForSpeculation ) -import PprCore () -- Instances -import CostCentre ( CostCentreStack, subsumedCCS ) -import OccName ( UserFS ) -import VarEnv -import VarSet -import OrdList -import qualified Subst -import Subst ( Subst, mkSubst, substEnv, - InScopeSet, mkInScopeSet, substInScope - ) -import Type ( Type, isUnLiftedType ) +import Id ( Id, mkSysLocal ) +import Type ( Type ) import UniqSupply ( uniqsFromSupply, uniqFromSupply, splitUniqSupply, UniqSupply ) -import FiniteMap -import CmdLineOpts ( SimplifierSwitch(..), SwitchResult(..), - DynFlags, DynFlag(..), dopt, - opt_PprStyle_Debug, opt_HistorySize, - intSwitchSet - ) +import DynFlags ( SimplifierSwitch(..), DynFlags, DynFlag(..), dopt ) +import StaticFlags ( opt_PprStyle_Debug, opt_HistorySize ) import Unique ( Unique ) import Maybes ( expectJust ) -import Util ( zipWithEqual ) +import FiniteMap ( FiniteMap, emptyFM, isEmptyFM, lookupFM, addToFM, plusFM_C, fmToList ) +import FastString ( FastString ) import Outputable +import FastTypes -infixr 0 `thenSmpl`, `thenSmpl_` -\end{code} +import GLAEXTS ( indexArray# ) -%************************************************************************ -%* * -\subsection[Simplify-types]{Type declarations} -%* * -%************************************************************************ - -\begin{code} -type InBinder = CoreBndr -type InId = Id -- Not yet cloned -type InType = Type -- Ditto -type InBind = CoreBind -type InExpr = CoreExpr -type InAlt = CoreAlt -type InArg = CoreArg - -type OutBinder = CoreBndr -type OutId = Id -- Cloned -type OutType = Type -- Cloned -type OutBind = CoreBind -type OutExpr = CoreExpr -type OutAlt = CoreAlt -type OutArg = CoreArg +#if __GLASGOW_HASKELL__ < 503 +import PrelArr ( Array(..) ) +#else +import GHC.Arr ( Array(..) ) +#endif -type SwitchChecker = SimplifierSwitch -> SwitchResult - -type OutExprStuff = OutStuff OutExpr -type OutStuff a = (OrdList OutBind, (InScopeSet, a)) - -- We return something equivalent to (let b in e), but - -- in pieces to avoid the quadratic blowup when floating - -- incrementally. Comments just before simplExprB in Simplify.lhs -\end{code} +import Array ( array, (//) ) -\begin{code} -wrapFloats :: OrdList CoreBind -> CoreExpr -> CoreExpr -wrapFloats binds body = foldOL Let body binds - -returnOutStuff :: a -> SimplM (OutStuff a) -returnOutStuff x = getInScope `thenSmpl` \ in_scope -> - returnSmpl (nilOL, (in_scope, x)) - -addFloats :: OrdList CoreBind -> InScopeSet -> SimplM (OutStuff a) -> SimplM (OutStuff a) -addFloats floats in_scope thing_inside - = setInScope in_scope thing_inside `thenSmpl` \ (binds, res) -> - returnSmpl (floats `appOL` binds, res) - -addLetBind :: CoreBind -> SimplM (OutStuff a) -> SimplM (OutStuff a) -addLetBind bind thing_inside - = thing_inside `thenSmpl` \ (binds, res) -> - returnSmpl (bind `consOL` binds, res) - -addLetBinds :: [CoreBind] -> SimplM (OutStuff a) -> SimplM (OutStuff a) -addLetBinds binds1 thing_inside - = thing_inside `thenSmpl` \ (binds2, res) -> - returnSmpl (toOL binds1 `appOL` binds2, res) - -addAuxiliaryBinds :: [CoreBind] -> SimplM (OutStuff a) -> SimplM (OutStuff a) - -- Extends the in-scope environment as well as wrapping the bindings -addAuxiliaryBinds binds1 thing_inside - = addNewInScopeIds (bindersOfBinds binds1) $ - addLetBinds binds1 thing_inside - -addAuxiliaryBind :: CoreBind -> SimplM (OutStuff a) -> SimplM (OutStuff a) - -- Extends the in-scope environment as well as wrapping the bindings -addAuxiliaryBind bind thing_inside - = addNewInScopeIds (bindersOf bind) $ - addLetBind bind thing_inside - -needsCaseBinding ty rhs = isUnLiftedType ty && not (exprOkForSpeculation rhs) - -- Make a case expression instead of a let - -- These can arise either from the desugarer, - -- or from beta reductions: (\x.e) (x +# y) - -addCaseBind bndr rhs thing_inside - = thing_inside `thenSmpl` \ (floats, (_, body)) -> - returnOutStuff (Case rhs bndr [(DEFAULT, [], wrapFloats floats body)]) - -addNonRecBind bndr rhs thing_inside - -- Checks for needing a case binding - | needsCaseBinding (idType bndr) rhs = addCaseBind bndr rhs thing_inside - | otherwise = addLetBind (NonRec bndr rhs) thing_inside +infixr 0 `thenSmpl`, `thenSmpl_` \end{code} - %************************************************************************ %* * \subsection{Monad plumbing} @@ -174,52 +64,21 @@ For the simplifier monad, we want to {\em thread} a unique supply and a counter. (Command-line switches move around through the explicitly-passed SimplEnv.) \begin{code} -type SimplM result - = DynFlags - -> SimplEnv -- We thread the unique supply because - -> UniqSupply -- constantly splitting it is rather expensive - -> SimplCount - -> (result, UniqSupply, SimplCount) - -type BlackList = Id -> Bool -- True => don't inline this Id - -data SimplEnv - = SimplEnv { - seChkr :: SwitchChecker, - seCC :: CostCentreStack, -- The enclosing CCS (when profiling) - seBlackList :: BlackList, - seSubst :: Subst -- The current substitution - } - -- The range of the substitution is OutType and OutExpr resp - -- - -- The substitution is idempotent - -- It *must* be applied; things in its domain simply aren't - -- bound in the result. - -- - -- The substitution usually maps an Id to its clone, - -- but if the orig defn is a let-binding, and - -- the RHS of the let simplifies to an atom, - -- we just add the binding to the substitution and elide the let. - - -- The in-scope part of Subst includes *all* in-scope TyVars and Ids - -- The elements of the set may have better IdInfo than the - -- occurrences of in-scope Ids, and (more important) they will - -- have a correctly-substituted type. So we use a lookup in this - -- set to replace occurrences +newtype SimplM result + = SM { unSM :: DynFlags -- We thread the unique supply because + -> UniqSupply -- constantly splitting it is rather expensive + -> SimplCount + -> (result, UniqSupply, SimplCount)} \end{code} \begin{code} initSmpl :: DynFlags - -> SwitchChecker -> UniqSupply -- No init count; set to 0 - -> VarSet -- In scope (usually empty, but useful for nested calls) - -> BlackList -- Black-list function -> SimplM a -> (a, SimplCount) -initSmpl dflags chkr us in_scope black_list m - = case m dflags (emptySimplEnv chkr in_scope black_list) us - (zeroSimplCount dflags) of +initSmpl dflags us m + = case unSM m dflags us (zeroSimplCount dflags) of (result, _, count) -> (result, count) @@ -227,19 +86,26 @@ initSmpl dflags chkr us in_scope black_list m {-# INLINE thenSmpl_ #-} {-# INLINE returnSmpl #-} +instance Monad SimplM where + (>>) = thenSmpl_ + (>>=) = thenSmpl + return = returnSmpl + returnSmpl :: a -> SimplM a -returnSmpl e dflags env us sc = (e, us, sc) +returnSmpl e = SM (\ dflags us sc -> (e, us, sc)) thenSmpl :: SimplM a -> (a -> SimplM b) -> SimplM b thenSmpl_ :: SimplM a -> SimplM b -> SimplM b -thenSmpl m k dflags env us0 sc0 - = case (m dflags env us0 sc0) of - (m_result, us1, sc1) -> k m_result dflags env us1 sc1 +thenSmpl m k + = SM (\ dflags us0 sc0 -> + case (unSM m dflags us0 sc0) of + (m_result, us1, sc1) -> unSM (k m_result) dflags us1 sc1 ) -thenSmpl_ m k dflags env us0 sc0 - = case (m dflags env us0 sc0) of - (_, us1, sc1) -> k dflags env us1 sc1 +thenSmpl_ m k + = SM (\dflags us0 sc0 -> + case (unSM m dflags us0 sc0) of + (_, us1, sc1) -> unSM k dflags us1 sc1) \end{code} @@ -259,6 +125,7 @@ mapAndUnzipSmpl f (x:xs) mapAndUnzipSmpl f xs `thenSmpl` \ (rs1, rs2) -> returnSmpl (r1:rs1, r2:rs2) +mapAccumLSmpl :: (acc -> b -> SimplM (acc,c)) -> acc -> [b] -> SimplM (acc, [c]) mapAccumLSmpl f acc [] = returnSmpl (acc, []) mapAccumLSmpl f acc (x:xs) = f acc x `thenSmpl` \ (acc', x') -> mapAccumLSmpl f acc' xs `thenSmpl` \ (acc'', xs') -> @@ -274,23 +141,27 @@ mapAccumLSmpl f acc (x:xs) = f acc x `thenSmpl` \ (acc', x') -> \begin{code} getUniqSupplySmpl :: SimplM UniqSupply -getUniqSupplySmpl dflags env us sc - = case splitUniqSupply us of - (us1, us2) -> (us1, us2, sc) +getUniqSupplySmpl + = SM (\dflags us sc -> case splitUniqSupply us of + (us1, us2) -> (us1, us2, sc)) getUniqueSmpl :: SimplM Unique -getUniqueSmpl dflags env us sc - = case splitUniqSupply us of - (us1, us2) -> (uniqFromSupply us1, us2, sc) +getUniqueSmpl + = SM (\dflags us sc -> case splitUniqSupply us of + (us1, us2) -> (uniqFromSupply us1, us2, sc)) getUniquesSmpl :: SimplM [Unique] -getUniquesSmpl dflags env us sc - = case splitUniqSupply us of - (us1, us2) -> (uniqsFromSupply us1, us2, sc) +getUniquesSmpl + = SM (\dflags us sc -> case splitUniqSupply us of + (us1, us2) -> (uniqsFromSupply us1, us2, sc)) getDOptsSmpl :: SimplM DynFlags -getDOptsSmpl dflags env us sc - = (dflags, us, sc) +getDOptsSmpl + = SM (\dflags us sc -> (dflags, us, sc)) + +newId :: FastString -> Type -> SimplM Id +newId fs ty = getUniqueSmpl `thenSmpl` \ uniq -> + returnSmpl (mkSysLocal fs uniq ty) \end{code} @@ -302,21 +173,19 @@ getDOptsSmpl dflags env us sc \begin{code} getSimplCount :: SimplM SimplCount -getSimplCount dflags env us sc = (sc, us, sc) +getSimplCount = SM (\dflags us sc -> (sc, us, sc)) tick :: Tick -> SimplM () -tick t dflags env us sc - = sc' `seq` ((), us, sc') - where - sc' = doTick t sc +tick t + = SM (\dflags us sc -> let sc' = doTick t sc + in sc' `seq` ((), us, sc')) freeTick :: Tick -> SimplM () -- Record a tick, but don't add to the total tick count, which is -- used to decide when nothing further has happened -freeTick t dflags env us sc - = sc' `seq` ((), us, sc') - where - sc' = doFreeTick t sc +freeTick t + = SM (\dflags us sc -> let sc' = doFreeTick t sc + in sc' `seq` ((), us, sc')) \end{code} \begin{code} @@ -444,7 +313,7 @@ data Tick | PostInlineUnconditionally Id | UnfoldingDone Id - | RuleFired FAST_STRING -- Rule name + | RuleFired FastString -- Rule name | LetFloatFromLet | EtaExpansion Id -- LHS binder @@ -455,6 +324,7 @@ data Tick | CaseOfCase Id -- Bndr on *inner* case | KnownBranch Id -- Case binder | CaseMerge Id -- Binder on outer case + | AltMerge Id -- Case binder | CaseElim Id -- Case binder | CaseIdentity Id -- Case binder | FillInCaseDefault Id -- Case binder @@ -491,6 +361,7 @@ tickToTag (CaseIdentity _) = 12 tickToTag (FillInCaseDefault _) = 13 tickToTag BottomFound = 14 tickToTag SimplifierDone = 16 +tickToTag (AltMerge _) = 17 tickString :: Tick -> String tickString (PreInlineUnconditionally _) = "PreInlineUnconditionally" @@ -504,6 +375,7 @@ tickString (BetaReduction _) = "BetaReduction" tickString (CaseOfCase _) = "CaseOfCase" tickString (KnownBranch _) = "KnownBranch" tickString (CaseMerge _) = "CaseMerge" +tickString (AltMerge _) = "AltMerge" tickString (CaseElim _) = "CaseElim" tickString (CaseIdentity _) = "CaseIdentity" tickString (FillInCaseDefault _) = "FillInCaseDefault" @@ -522,6 +394,7 @@ pprTickCts (BetaReduction v) = ppr v pprTickCts (CaseOfCase v) = ppr v pprTickCts (KnownBranch v) = ppr v pprTickCts (CaseMerge v) = ppr v +pprTickCts (AltMerge v) = ppr v pprTickCts (CaseElim v) = ppr v pprTickCts (CaseIdentity v) = ppr v pprTickCts (FillInCaseDefault v) = ppr v @@ -547,6 +420,7 @@ cmpEqTick (BetaReduction a) (BetaReduction b) = a `compare` b cmpEqTick (CaseOfCase a) (CaseOfCase b) = a `compare` b cmpEqTick (KnownBranch a) (KnownBranch b) = a `compare` b cmpEqTick (CaseMerge a) (CaseMerge b) = a `compare` b +cmpEqTick (AltMerge a) (AltMerge b) = a `compare` b cmpEqTick (CaseElim a) (CaseElim b) = a `compare` b cmpEqTick (CaseIdentity a) (CaseIdentity b) = a `compare` b cmpEqTick (FillInCaseDefault a) (FillInCaseDefault b) = a `compare` b @@ -561,195 +435,92 @@ cmpEqTick other1 other2 = EQ %************************************************************************ \begin{code} -getSwitchChecker :: SimplM SwitchChecker -getSwitchChecker dflags env us sc = (seChkr env, us, sc) +type SwitchChecker = SimplifierSwitch -> SwitchResult -getSimplIntSwitch :: SwitchChecker -> (Int-> SimplifierSwitch) -> Int -getSimplIntSwitch chkr switch - = expectJust "getSimplIntSwitch" (intSwitchSet chkr switch) +data SwitchResult + = SwBool Bool -- on/off + | SwString FastString -- nothing or a String + | SwInt Int -- nothing or an Int + +isAmongSimpl :: [SimplifierSwitch] -> SimplifierSwitch -> SwitchResult +isAmongSimpl on_switches -- Switches mentioned later occur *earlier* + -- in the list; defaults right at the end. + = let + tidied_on_switches = foldl rm_dups [] on_switches + -- The fold*l* ensures that we keep the latest switches; + -- ie the ones that occur earliest in the list. + + sw_tbl :: Array Int SwitchResult + sw_tbl = (array (0, lAST_SIMPL_SWITCH_TAG) -- bounds... + all_undefined) + // defined_elems + + all_undefined = [ (i, SwBool False) | i <- [0 .. lAST_SIMPL_SWITCH_TAG ] ] + + defined_elems = map mk_assoc_elem tidied_on_switches + in + -- (avoid some unboxing, bounds checking, and other horrible things:) + case sw_tbl of { Array _ _ stuff -> + \ switch -> + case (indexArray# stuff (tagOf_SimplSwitch switch)) of + (# v #) -> v + } + where + mk_assoc_elem k@(MaxSimplifierIterations lvl) + = (iBox (tagOf_SimplSwitch k), SwInt lvl) + mk_assoc_elem k + = (iBox (tagOf_SimplSwitch k), SwBool True) -- I'm here, Mom! + + -- cannot have duplicates if we are going to use the array thing + rm_dups switches_so_far switch + = if switch `is_elem` switches_so_far + then switches_so_far + else switch : switches_so_far + where + sw `is_elem` [] = False + sw `is_elem` (s:ss) = (tagOf_SimplSwitch sw) ==# (tagOf_SimplSwitch s) + || sw `is_elem` ss \end{code} - -@setBlackList@ is used to prepare the environment for simplifying -the RHS of an Id that's marked with an INLINE pragma. It is going to -be inlined wherever they are used, and then all the inlining will take -effect. Meanwhile, there isn't much point in doing anything to the -as-yet-un-INLINEd rhs. Furthremore, it's very important to switch off -inlining! because - (a) not doing so will inline a worker straight back into its wrapper! - -and (b) Consider the following example - let f = \pq -> BIG - in - let g = \y -> f y y - {-# INLINE g #-} - in ...g...g...g...g...g... - - Now, if that's the ONLY occurrence of f, it will be inlined inside g, - and thence copied multiple times when g is inlined. - - Andy disagrees! Example: - all xs = foldr (&&) True xs - any p = all . map p {-# INLINE any #-} - - Problem: any won't get deforested, and so if it's exported and - the importer doesn't use the inlining, (eg passes it as an arg) - then we won't get deforestation at all. - We havn't solved this problem yet! - -We prepare the envt by simply modifying the black list. - -6/98 update: - -We *don't* prevent inlining from happening for identifiers -that are marked as IMustBeINLINEd. An example of where -doing this is crucial is: - - class Bar a => Foo a where - ...g.... - {-# INLINE f #-} - f :: Foo a => a -> b - f x = ....Foo_sc1... - -If `f' needs to peer inside Foo's superclass, Bar, it refers -to the appropriate super class selector, which is marked as -must-inlineable. We don't generate any code for a superclass -selector, so failing to inline it in the RHS of `f' will -leave a reference to a non-existent id, with bad consequences. - -ALSO NOTE that we do all this by modifing the black list -not by zapping the unfolding. The latter may still be useful for -knowing when something is evaluated. - \begin{code} -setBlackList :: BlackList -> SimplM a -> SimplM a -setBlackList black_list m dflags env us sc - = m dflags (env { seBlackList = black_list }) us sc - -getBlackList :: SimplM BlackList -getBlackList dflags env us sc = (seBlackList env, us, sc) - -noInlineBlackList :: BlackList - -- Inside inlinings, black list anything that is in scope or imported. - -- except for things that must be unfolded (Compulsory) - -- and data con wrappers. The latter is a hack, like the one in - -- SimplCore.simplRules, to make wrappers inline in rule LHSs. - -- We may as well do the same here. -noInlineBlackList v = not (isCompulsoryUnfolding (idUnfolding v)) && - not (isDataConWrapId v) - -- NB: this implementation means that even inlinings *completely within* - -- an INLINE won't happen, which is perhaps overkill. - -- An earlier verion had: (v `isInScope` subst) || not (isLocallyDefined v) - -- but it's more expensive, and it probably doesn't matter. -\end{code} +getSimplIntSwitch :: SwitchChecker -> (Int-> SimplifierSwitch) -> Int +getSimplIntSwitch chkr switch + = expectJust "getSimplIntSwitch" (intSwitchSet chkr switch) +switchIsOn :: (switch -> SwitchResult) -> switch -> Bool -%************************************************************************ -%* * -\subsubsection{The ``enclosing cost-centre''} -%* * -%************************************************************************ +switchIsOn lookup_fn switch + = case (lookup_fn switch) of + SwBool False -> False + _ -> True -\begin{code} -getEnclosingCC :: SimplM CostCentreStack -getEnclosingCC dflags env us sc = (seCC env, us, sc) +intSwitchSet :: (switch -> SwitchResult) + -> (Int -> switch) + -> Maybe Int -setEnclosingCC :: CostCentreStack -> SimplM a -> SimplM a -setEnclosingCC cc m dflags env us sc = m dflags (env { seCC = cc }) us sc +intSwitchSet lookup_fn switch + = case (lookup_fn (switch (panic "intSwitchSet"))) of + SwInt int -> Just int + _ -> Nothing \end{code} -%************************************************************************ -%* * -\subsubsection{The @SimplEnv@ type} -%* * -%************************************************************************ - +These things behave just like enumeration types. \begin{code} -emptySimplEnv :: SwitchChecker -> VarSet -> (Id -> Bool) -> SimplEnv +instance Eq SimplifierSwitch where + a == b = tagOf_SimplSwitch a ==# tagOf_SimplSwitch b -emptySimplEnv sw_chkr in_scope black_list - = SimplEnv { seChkr = sw_chkr, seCC = subsumedCCS, - seBlackList = black_list, - seSubst = mkSubst (mkInScopeSet in_scope) emptySubstEnv } - -- The top level "enclosing CC" is "SUBSUMED". +instance Ord SimplifierSwitch where + a < b = tagOf_SimplSwitch a <# tagOf_SimplSwitch b + a <= b = tagOf_SimplSwitch a <=# tagOf_SimplSwitch b -getEnv :: SimplM SimplEnv -getEnv dflags env us sc = (env, us, sc) -setAllExceptInScope :: SimplEnv -> SimplM a -> SimplM a -setAllExceptInScope new_env@(SimplEnv {seSubst = new_subst}) m dflags - (SimplEnv {seSubst = old_subst}) us sc - = m dflags (new_env {seSubst = Subst.setInScope new_subst (substInScope old_subst)}) - us sc +tagOf_SimplSwitch (MaxSimplifierIterations _) = _ILIT(1) +tagOf_SimplSwitch NoCaseOfCase = _ILIT(2) -getSubst :: SimplM Subst -getSubst dflags env us sc = (seSubst env, us, sc) +-- If you add anything here, be sure to change lAST_SIMPL_SWITCH_TAG, too! -setSubst :: Subst -> SimplM a -> SimplM a -setSubst subst m dflags env us sc = m dflags (env {seSubst = subst}) us sc - -getSubstEnv :: SimplM SubstEnv -getSubstEnv dflags env us sc = (substEnv (seSubst env), us, sc) - -addNewInScopeIds :: [CoreBndr] -> SimplM a -> SimplM a - -- The new Ids are guaranteed to be freshly allocated -addNewInScopeIds vs m dflags env@(SimplEnv {seSubst = subst}) us sc - = m dflags (env {seSubst = Subst.extendNewInScopeList subst vs}) us sc - -getInScope :: SimplM InScopeSet -getInScope dflags env us sc = (substInScope (seSubst env), us, sc) - -setInScope :: InScopeSet -> SimplM a -> SimplM a -setInScope in_scope m dflags env@(SimplEnv {seSubst = subst}) us sc - = m dflags (env {seSubst = Subst.setInScope subst in_scope}) us sc - -modifyInScope :: CoreBndr -> CoreBndr -> SimplM a -> SimplM a -modifyInScope v v' m dflags env@(SimplEnv {seSubst = subst}) us sc - = m dflags (env {seSubst = Subst.modifyInScope subst v v'}) us sc - -extendSubst :: CoreBndr -> SubstResult -> SimplM a -> SimplM a -extendSubst var res m dflags env@(SimplEnv {seSubst = subst}) us sc - = m dflags (env { seSubst = Subst.extendSubst subst var res }) us sc - -extendSubstList :: [CoreBndr] -> [SubstResult] -> SimplM a -> SimplM a -extendSubstList vars ress m dflags env@(SimplEnv {seSubst = subst}) us sc - = m dflags (env { seSubst = Subst.extendSubstList subst vars ress }) us sc - -setSubstEnv :: SubstEnv -> SimplM a -> SimplM a -setSubstEnv senv m dflags env@(SimplEnv {seSubst = subst}) us sc - = m dflags (env {seSubst = Subst.setSubstEnv subst senv}) us sc - -zapSubstEnv :: SimplM a -> SimplM a -zapSubstEnv m dflags env@(SimplEnv {seSubst = subst}) us sc - = m dflags (env {seSubst = Subst.zapSubstEnv subst}) us sc - -getSimplBinderStuff :: SimplM (Subst, UniqSupply) -getSimplBinderStuff dflags (SimplEnv {seSubst = subst}) us sc - = ((subst, us), us, sc) - -setSimplBinderStuff :: (Subst, UniqSupply) -> SimplM a -> SimplM a -setSimplBinderStuff (subst, us) m dflags env _ sc - = m dflags (env {seSubst = subst}) us sc +lAST_SIMPL_SWITCH_TAG = 2 \end{code} - -\begin{code} -newId :: UserFS -> Type -> (Id -> SimplM a) -> SimplM a - -- Extends the in-scope-env too -newId fs ty m dflags env@(SimplEnv {seSubst = subst}) us sc - = case splitUniqSupply us of - (us1, us2) -> m v dflags (env {seSubst = Subst.extendNewInScope subst v}) - us2 sc - where - v = mkSysLocal fs (uniqFromSupply us1) ty - -newIds :: UserFS -> [Type] -> ([Id] -> SimplM a) -> SimplM a -newIds fs tys m dflags env@(SimplEnv {seSubst = subst}) us sc - = case splitUniqSupply us of - (us1, us2) -> m vs dflags (env {seSubst = Subst.extendNewInScopeList subst vs}) - us2 sc - where - vs = zipWith (mkSysLocal fs) (uniqsFromSupply us1) tys -\end{code}