projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
(F)SLIT -> (f)sLit in SimplEnv
[ghc-hetmet.git]
/
compiler
/
simplCore
/
SimplEnv.lhs
diff --git
a/compiler/simplCore/SimplEnv.lhs
b/compiler/simplCore/SimplEnv.lhs
index
1b05737
..
127e8cb
100644
(file)
--- a/
compiler/simplCore/SimplEnv.lhs
+++ b/
compiler/simplCore/SimplEnv.lhs
@@
-46,7
+46,7
@@
module SimplEnv (
#include "HsVersions.h"
#include "HsVersions.h"
-import SimplMonad
+import SimplMonad
import IdInfo
import CoreSyn
import Rules
import IdInfo
import CoreSyn
import Rules
@@
-64,7
+64,9
@@
import Coercion
import BasicTypes
import DynFlags
import Util
import BasicTypes
import DynFlags
import Util
+import MonadUtils
import Outputable
import Outputable
+import FastString
import Data.List
\end{code}
import Data.List
\end{code}
@@
-126,8
+128,8
@@
data SimplEnv
pprSimplEnv :: SimplEnv -> SDoc
-- Used for debugging; selective
pprSimplEnv env
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
type SimplIdSubst = IdEnv SimplSR -- IdId |--> OutExpr
-- See Note [Extending the Subst] in CoreSubst
@@
-140,9
+142,9
@@
data SimplSR
InExpr
instance Outputable SimplSR where
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
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 (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 :: 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 }
= 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
-- 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
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;
addFloats :: SimplEnv -> SimplEnv -> SimplEnv
-- Add the floats for env2 to env1;
@@
-455,15
+455,19
@@
floatBinds (Floats bs _) = fromOL bs
\begin{code}
\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)
= DoneId v
| otherwise -- A local Id
= case lookupVarEnv ids v of
substId (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v
| not (isLocalId v)
= DoneId v
| otherwise -- A local Id
= case lookupVarEnv ids v of
- Just (DoneId v) -> DoneId (refine in_scope v)
- Just res -> res
- Nothing -> DoneId (refine in_scope v)
+ Nothing -> DoneId (refine in_scope v)
+ Just (DoneId 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
-- Get the most up-to-date thing from the in-scope set
where
-- Get the most up-to-date thing from the in-scope set
@@
-473,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!
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
-- 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
@@
-496,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])
\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)
-------------
simplBinder :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)
@@
-515,18
+519,19
@@
simplBinder env bndr
-------------
simplLamBndr :: SimplEnv -> Var -> SimplM (SimplEnv, Var)
-- Used for lambda binders. These sometimes have unfoldings added by
-------------
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
-- 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
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)
---------------
simplNonRecBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)
@@
-617,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.
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
allows us to eta-reduce
f = \x -> f x
to
@@
-655,7
+660,7
@@
addBndrRules env in_id out_id
where
subst = mkCoreSubst env
old_rules = idSpecialisation in_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
------------------
final_id = out_id `setIdSpecialisation` new_rules
------------------