X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FsimplCore%2FSimplEnv.lhs;h=1c3b8d8f60bbddee61475f97ac8a9bd19152bfae;hp=bb98032e1049e1c76e6fc7fcfc4ef9b4141114da;hb=5699ec476d64d48b7fcf6812238406e1eea91bef;hpb=41676ec859d1332d4c4ec56c9ea8b0aa9cedf606 diff --git a/compiler/simplCore/SimplEnv.lhs b/compiler/simplCore/SimplEnv.lhs index bb98032..1c3b8d8 100644 --- a/compiler/simplCore/SimplEnv.lhs +++ b/compiler/simplCore/SimplEnv.lhs @@ -4,13 +4,6 @@ \section[SimplMonad]{The simplifier Monad} \begin{code} -{-# OPTIONS -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details - module SimplEnv ( InId, InBind, InExpr, InAlt, InArg, InType, InBndr, OutId, OutTyVar, OutBind, OutExpr, OutAlt, OutArg, OutType, OutBndr, @@ -46,10 +39,9 @@ module SimplEnv ( #include "HsVersions.h" -import SimplMonad +import SimplMonad import IdInfo import CoreSyn -import Rules import CoreUtils import CostCentre import Var @@ -63,8 +55,9 @@ import Type hiding ( substTy, substTyVarBndr ) import Coercion import BasicTypes import DynFlags -import Util +import MonadUtils import Outputable +import FastString import Data.List \end{code} @@ -126,8 +119,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 +133,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,14 +336,14 @@ 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 andFF FltOkSpec FltCareful = FltCareful -andFF FltOkSpec flt = FltOkSpec +andFF FltOkSpec _ = FltOkSpec andFF FltLifted flt = flt classifyFF :: CoreBind -> FloatFlag @@ -389,15 +382,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; @@ -420,7 +411,7 @@ addRecFloats :: SimplEnv -> SimplEnv -> SimplEnv -- This is all very specific to the way recursive bindings are -- handled; see Simplify.simplRecBind addRecFloats env1 env2@(SimplEnv {seFloats = Floats bs ff}) - = ASSERT2( case ff of { FltLifted -> True; other -> False }, ppr (fromOL bs) ) + = ASSERT2( case ff of { FltLifted -> True; _ -> False }, ppr (fromOL bs) ) env2 {seFloats = seFloats env1 `addFlts` unitFloat (Rec (flattenBinds (fromOL bs)))} wrapFloats :: SimplEnv -> OutExpr -> OutExpr @@ -473,6 +464,7 @@ substId (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v -- Get the most up-to-date thing from the in-scope set -- Even though it isn't in the substitution, it may be in -- the in-scope set with better IdInfo +refine :: InScopeSet -> Var -> Var refine in_scope v = case lookupInScope in_scope v of Just v' -> v' Nothing -> WARN( True, ppr v ) v -- This is an error! @@ -483,8 +475,8 @@ lookupRecBndr :: SimplEnv -> InId -> OutId lookupRecBndr (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v = case lookupVarEnv ids v of Just (DoneId v) -> v - Just res -> pprPanic "lookupRecBndr" (ppr v) - Nothing -> refine in_scope v + Just _ -> pprPanic "lookupRecBndr" (ppr v) + Nothing -> refine in_scope v \end{code} @@ -500,8 +492,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) @@ -543,7 +535,7 @@ simplNonRecBndr env id --------------- simplRecBndrs :: SimplEnv -> [InBndr] -> SimplM SimplEnv -- Recursive let binders -simplRecBndrs env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) ids +simplRecBndrs env@(SimplEnv {}) ids = do { let (env1, ids1) = mapAccumL substIdBndr env ids ; seqIds ids1 `seq` return env1 } @@ -665,7 +657,7 @@ addBndrRules env in_id out_id ------------------ substIdType :: SimplEnv -> Id -> Id -substIdType env@(SimplEnv { seInScope = in_scope, seTvSubst = tv_env}) id +substIdType (SimplEnv { seInScope = in_scope, seTvSubst = tv_env}) id | isEmptyVarEnv tv_env || isEmptyVarSet (tyVarsOfType old_ty) = id | otherwise = Id.setIdType id (Type.substTy (TvSubst in_scope tv_env) old_ty) -- The tyVarsOfType is cheaper than it looks @@ -676,14 +668,14 @@ substIdType env@(SimplEnv { seInScope = in_scope, seTvSubst = tv_env}) id ------------------ substUnfolding :: SimplEnv -> Unfolding -> Unfolding -substUnfolding env NoUnfolding = NoUnfolding -substUnfolding env (OtherCon cons) = OtherCon cons +substUnfolding _ NoUnfolding = NoUnfolding +substUnfolding _ (OtherCon cons) = OtherCon cons substUnfolding env (CompulsoryUnfolding rhs) = CompulsoryUnfolding (substExpr env rhs) substUnfolding env (CoreUnfolding rhs t v w g) = CoreUnfolding (substExpr env rhs) t v w g ------------------ substWorker :: SimplEnv -> WorkerInfo -> WorkerInfo -substWorker env NoWorker = NoWorker +substWorker _ NoWorker = NoWorker substWorker env wkr_info = CoreSubst.substWorker (mkCoreSubst env) wkr_info \end{code}