(F)SLIT -> (f)sLit in StaticFlags

[ghc-hetmet.git] / compiler / simplCore / SimplEnv.lhs

diff --git a/compiler/simplCore/SimplEnv.lhs b/compiler/simplCore/SimplEnv.lhs
index 762758f..127e8cb 100644 (file)
--- 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; 
@@ -500,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)
@@ -519,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)