X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FSimplEnv.lhs;h=127e8cbef933c55ed9bd484879a82ec93cc029ab;hb=a425df1a4e65b24018db36d4f9b919fc8af3447e;hp=d0240fb961fb8c63d93f499ddfbe5252ca894a6b;hpb=58e45ee86bbda3f24a4caf41c0aea7a6b787367e;p=ghc-hetmet.git diff --git a/compiler/simplCore/SimplEnv.lhs b/compiler/simplCore/SimplEnv.lhs index d0240fb..127e8cb 100644 --- a/compiler/simplCore/SimplEnv.lhs +++ b/compiler/simplCore/SimplEnv.lhs @@ -46,7 +46,7 @@ module SimplEnv ( #include "HsVersions.h" -import SimplMonad +import SimplMonad import IdInfo import CoreSyn import Rules @@ -64,7 +64,9 @@ import Coercion import BasicTypes import DynFlags import Util +import MonadUtils import Outputable +import FastString import Data.List \end{code} @@ -126,8 +128,8 @@ data SimplEnv pprSimplEnv :: SimplEnv -> SDoc -- Used for debugging; selective pprSimplEnv env - = vcat [ptext SLIT("TvSubst:") <+> ppr (seTvSubst env), - ptext SLIT("IdSubst:") <+> ppr (seIdSubst env) ] + = vcat [ptext (sLit "TvSubst:") <+> ppr (seTvSubst env), + ptext (sLit "IdSubst:") <+> ppr (seIdSubst env) ] type SimplIdSubst = IdEnv SimplSR -- IdId |--> OutExpr -- See Note [Extending the Subst] in CoreSubst @@ -140,9 +142,9 @@ data SimplSR InExpr instance Outputable SimplSR where - ppr (DoneEx e) = ptext SLIT("DoneEx") <+> ppr e - ppr (DoneId v) = ptext SLIT("DoneId") <+> ppr v - ppr (ContEx tv id e) = vcat [ptext SLIT("ContEx") <+> ppr e {-, + ppr (DoneEx e) = ptext (sLit "DoneEx") <+> ppr e + ppr (DoneId v) = ptext (sLit "DoneId") <+> ppr v + ppr (ContEx tv id e) = vcat [ptext (sLit "ContEx") <+> ppr e {-, ppr (filter_env tv), ppr (filter_env id) -}] -- where -- fvs = exprFreeVars e @@ -343,9 +345,9 @@ instance Outputable Floats where ppr (Floats binds ff) = ppr ff $$ ppr (fromOL binds) instance Outputable FloatFlag where - ppr FltLifted = ptext SLIT("FltLifted") - ppr FltOkSpec = ptext SLIT("FltOkSpec") - ppr FltCareful = ptext SLIT("FltCareful") + ppr FltLifted = ptext (sLit "FltLifted") + ppr FltOkSpec = ptext (sLit "FltOkSpec") + ppr FltCareful = ptext (sLit "FltCareful") andFF :: FloatFlag -> FloatFlag -> FloatFlag andFF FltCareful _ = FltCareful @@ -389,15 +391,13 @@ addNonRec env id rhs = env { seFloats = seFloats env `addFlts` unitFloat (NonRec id rhs), seInScope = extendInScopeSet (seInScope env) id } -extendFloats :: SimplEnv -> [OutBind] -> SimplEnv +extendFloats :: SimplEnv -> OutBind -> SimplEnv -- Add these bindings to the floats, and extend the in-scope env too -extendFloats env binds - = env { seFloats = seFloats env `addFlts` new_floats, +extendFloats env bind + = env { seFloats = seFloats env `addFlts` unitFloat bind, seInScope = extendInScopeSetList (seInScope env) bndrs } where - bndrs = bindersOfBinds binds - new_floats = Floats (toOL binds) - (foldr (andFF . classifyFF) FltLifted binds) + bndrs = bindersOf bind addFloats :: SimplEnv -> SimplEnv -> SimplEnv -- Add the floats for env2 to env1; @@ -455,7 +455,7 @@ floatBinds (Floats bs _) = fromOL bs \begin{code} -substId :: SimplEnv -> Id -> SimplSR +substId :: SimplEnv -> InId -> SimplSR -- Returns DoneEx only on a non-Var expression substId (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v | not (isLocalId v) @@ -464,7 +464,9 @@ substId (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v = case lookupVarEnv ids v of Nothing -> DoneId (refine in_scope v) Just (DoneId v) -> DoneId (refine in_scope v) - Just (DoneEx (Var v)) -> DoneId (refine in_scope v) + Just (DoneEx (Var v)) + | isLocalId v -> DoneId (refine in_scope v) + | otherwise -> DoneId v Just res -> res -- DoneEx non-var, or ContEx where @@ -475,7 +477,7 @@ refine in_scope v = case lookupInScope in_scope v of Just v' -> v' Nothing -> WARN( True, ppr v ) v -- This is an error! -lookupRecBndr :: SimplEnv -> Id -> Id +lookupRecBndr :: SimplEnv -> InId -> OutId -- Look up an Id which has been put into the envt by simplRecBndrs, -- but where we have not yet done its RHS lookupRecBndr (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v @@ -498,8 +500,8 @@ These functions are in the monad only so that they can be made strict via seq. \begin{code} simplBinders, simplLamBndrs :: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [OutBndr]) -simplBinders env bndrs = mapAccumLSmpl simplBinder env bndrs -simplLamBndrs env bndrs = mapAccumLSmpl simplLamBndr env bndrs +simplBinders env bndrs = mapAccumLM simplBinder env bndrs +simplLamBndrs env bndrs = mapAccumLM simplLamBndr env bndrs ------------- simplBinder :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr) @@ -517,18 +519,19 @@ simplBinder env bndr ------------- simplLamBndr :: SimplEnv -> Var -> SimplM (SimplEnv, Var) -- Used for lambda binders. These sometimes have unfoldings added by --- the worker/wrapper pass that must be preserved, becuase they can't +-- the worker/wrapper pass that must be preserved, because they can't -- be reconstructed from context. For example: -- f x = case x of (a,b) -> fw a b x -- fw a b x{=(a,b)} = ... -- The "{=(a,b)}" is an unfolding we can't reconstruct otherwise. simplLamBndr env bndr - | not (isId bndr && hasSomeUnfolding old_unf) = simplBinder env bndr -- Normal case - | otherwise = seqId id2 `seq` return (env', id2) + | isId bndr && hasSomeUnfolding old_unf = seqId id2 `seq` return (env2, id2) -- Special case + | otherwise = simplBinder env bndr -- Normal case where old_unf = idUnfolding bndr - (env', id1) = substIdBndr env bndr - id2 = id1 `setIdUnfolding` substUnfolding env old_unf + (env1, id1) = substIdBndr env bndr + id2 = id1 `setIdUnfolding` substUnfolding env old_unf + env2 = modifyInScope env1 id1 id2 --------------- simplNonRecBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr) @@ -619,7 +622,7 @@ Can we eta-expand f? Only if we see that f has arity 1, and then we take advantage of the 'state hack' on the result of (f y) :: State# -> (State#, Int) to expand the arity one more. -There is a disadvantage though. Making the arity visible in the RHA +There is a disadvantage though. Making the arity visible in the RHS allows us to eta-reduce f = \x -> f x to @@ -657,7 +660,7 @@ addBndrRules env in_id out_id where subst = mkCoreSubst env old_rules = idSpecialisation in_id - new_rules = CoreSubst.substSpec subst old_rules + new_rules = CoreSubst.substSpec subst out_id old_rules final_id = out_id `setIdSpecialisation` new_rules ------------------