Use OPTIONS rather than OPTIONS_GHC for pragmas

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

diff --git a/compiler/simplCore/SimplEnv.lhs b/compiler/simplCore/SimplEnv.lhs
index 00f035e..649dd1b 100644 (file)
--- a/compiler/simplCore/SimplEnv.lhs
+++ b/compiler/simplCore/SimplEnv.lhs
@@ -4,9 +4,17 @@
 \section[SimplMonad]{The simplifier Monad}
 
 \begin{code}
 \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/CodingStyle#Warnings
+-- for details
+

 module SimplEnv (
 module SimplEnv (

-       InId, InBind, InExpr, InAlt, InArg, InType, InBinder,
-       OutId, OutTyVar, OutBind, OutExpr, OutAlt, OutArg, OutType, OutBinder,
+       InId, InBind, InExpr, InAlt, InArg, InType, InBndr,
+       OutId, OutTyVar, OutBind, OutExpr, OutAlt, OutArg, OutType, OutBndr,
+        InCoercion, OutCoercion,

 
        -- The simplifier mode
        setMode, getMode, 
 
        -- The simplifier mode
        setMode, getMode, 

@@ -18,52 +26,47 @@ module SimplEnv (
        setEnclosingCC, getEnclosingCC,
 
        -- Environments
        setEnclosingCC, getEnclosingCC,
 
        -- Environments

-       SimplEnv, mkSimplEnv, extendIdSubst, extendTvSubst, 
+       SimplEnv(..), pprSimplEnv,      -- Temp not abstract
+       mkSimplEnv, extendIdSubst, SimplEnv.extendTvSubst, 

        zapSubstEnv, setSubstEnv, 
        getInScope, setInScope, setInScopeSet, modifyInScope, addNewInScopeIds,
        zapSubstEnv, setSubstEnv, 
        getInScope, setInScope, setInScopeSet, modifyInScope, addNewInScopeIds,

-       getRules, refineSimplEnv,
+       getRules, 

 
 

-       SimplSR(..), mkContEx, substId, 
+       SimplSR(..), mkContEx, substId, lookupRecBndr,

 
        simplNonRecBndr, simplRecBndrs, simplLamBndr, simplLamBndrs, 
        simplBinder, simplBinders, addLetIdInfo,
 
        simplNonRecBndr, simplRecBndrs, simplLamBndr, simplLamBndrs, 
        simplBinder, simplBinders, addLetIdInfo,

-       substExpr, substTy,
+       substExpr, substTy, 

 
        -- Floats
 
        -- Floats

-       FloatsWith, FloatsWithExpr,
-       Floats, emptyFloats, isEmptyFloats, unitFloat, addFloats, flattenFloats,
-       allLifted, wrapFloats, floatBinds,
-       addAuxiliaryBind,
+       Floats, emptyFloats, isEmptyFloats, addNonRec, addFloats, extendFloats,
+       wrapFloats, floatBinds, setFloats, zapFloats, addRecFloats,
+       doFloatFromRhs, getFloats

     ) where
 
 #include "HsVersions.h"
 
 import SimplMonad      
     ) where
 
 #include "HsVersions.h"
 
 import SimplMonad      

-import Id              ( Id, idType, idOccInfo, idUnfolding, setIdUnfolding )
-import IdInfo          ( IdInfo, vanillaIdInfo, occInfo, setOccInfo, specInfo, setSpecInfo,
-                         arityInfo, setArityInfo, workerInfo, setWorkerInfo, 
-                         unfoldingInfo, setUnfoldingInfo, isEmptySpecInfo,
-                         unknownArity, workerExists
-                           )
+import IdInfo

 import CoreSyn
 import CoreSyn

-import Unify           ( TypeRefinement )
-import Rules           ( RuleBase )
-import CoreUtils       ( needsCaseBinding )
-import CostCentre      ( CostCentreStack, subsumedCCS )
-import Var     
+import Rules
+import CoreUtils
+import CostCentre
+import Var

 import VarEnv
 import VarEnv

-import VarSet          ( isEmptyVarSet )
+import VarSet

 import OrdList
 import OrdList

-
+import Id

 import qualified CoreSubst     ( Subst, mkSubst, substExpr, substSpec, substWorker )
 import qualified Type          ( substTy, substTyVarBndr )
 import qualified CoreSubst     ( Subst, mkSubst, substExpr, substSpec, substWorker )
 import qualified Type          ( substTy, substTyVarBndr )

-
-import Type             ( Type, TvSubst(..), TvSubstEnv, composeTvSubst,
-                         isUnLiftedType, seqType, tyVarsOfType )
-import BasicTypes      ( OccInfo(..), isFragileOcc )
-import DynFlags                ( SimplifierMode(..) )
-import Util            ( mapAccumL )
+import Type hiding             ( substTy, substTyVarBndr )
+import Coercion
+import BasicTypes      
+import DynFlags
+import Util

 import Outputable
 import Outputable

+
+import Data.List

 \end{code}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************

@@ -73,22 +76,24 @@ import Outputable
 %************************************************************************
 
 \begin{code}
 %************************************************************************
 
 \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 OutTyVar  = TyVar                 -- Cloned
-type OutType   = Type                  -- Cloned
-type OutBind   = CoreBind
-type OutExpr   = CoreExpr
-type OutAlt    = CoreAlt
-type OutArg    = CoreArg
+type InBndr     = CoreBndr
+type InId       = Id                   -- Not yet cloned
+type InType     = Type                 -- Ditto
+type InBind     = CoreBind
+type InExpr     = CoreExpr
+type InAlt      = CoreAlt
+type InArg      = CoreArg
+type InCoercion = Coercion
+
+type OutBndr     = CoreBndr
+type OutId      = Id                   -- Cloned
+type OutTyVar   = TyVar                -- Cloned
+type OutType    = Type                 -- Cloned
+type OutCoercion = Coercion
+type OutBind    = CoreBind
+type OutExpr    = CoreExpr
+type OutAlt     = CoreAlt
+type OutArg     = CoreArg

 \end{code}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************

@@ -105,26 +110,44 @@ data SimplEnv
        seChkr      :: SwitchChecker,
        seCC        :: CostCentreStack, -- The enclosing CCS (when profiling)
 
        seChkr      :: SwitchChecker,
        seCC        :: CostCentreStack, -- The enclosing CCS (when profiling)
 

-       -- Rules from other modules
-       seExtRules  :: RuleBase,
-

        -- The current set of in-scope variables
        -- They are all OutVars, and all bound in this module
        seInScope   :: InScopeSet,      -- OutVars only
        -- The current set of in-scope variables
        -- They are all OutVars, and all bound in this module
        seInScope   :: InScopeSet,      -- OutVars only

+               -- Includes all variables bound by seFloats
+       seFloats    :: Floats,
+               -- See Note [Simplifier floats]

 
        -- The current substitution
        seTvSubst   :: TvSubstEnv,      -- InTyVar |--> OutType
        seIdSubst   :: SimplIdSubst     -- InId    |--> OutExpr
 
        -- The current substitution
        seTvSubst   :: TvSubstEnv,      -- InTyVar |--> OutType
        seIdSubst   :: SimplIdSubst     -- InId    |--> OutExpr

+

     }
 
     }
 

+pprSimplEnv :: SimplEnv -> SDoc
+-- Used for debugging; selective
+pprSimplEnv env
+  = vcat [ptext SLIT("TvSubst:") <+> ppr (seTvSubst env),
+         ptext SLIT("IdSubst:") <+> ppr (seIdSubst env) ]
+

 type SimplIdSubst = IdEnv SimplSR      -- IdId |--> OutExpr
 type SimplIdSubst = IdEnv SimplSR      -- IdId |--> OutExpr

+       -- See Note [Extending the Subst] in CoreSubst

 
 data SimplSR
   = DoneEx OutExpr             -- Completed term
 
 data SimplSR
   = DoneEx OutExpr             -- Completed term

-  | DoneId OutId OccInfo       -- Completed term variable, with occurrence info
+  | DoneId OutId               -- Completed term variable

   | ContEx TvSubstEnv          -- A suspended substitution
           SimplIdSubst
           InExpr        
   | ContEx TvSubstEnv          -- A suspended substitution
           SimplIdSubst
           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 (filter_env tv), ppr (filter_env id) -}]
+       -- where
+       -- fvs = exprFreeVars e
+       -- filter_env env = filterVarEnv_Directly keep env
+       -- keep uniq _ = uniq `elemUFM_Directly` fvs

 \end{code}
 
 
 \end{code}
 
 

@@ -148,11 +171,6 @@ seIdSubst:
                a77 -> a77
        from the substitution, when we decide not to clone a77, but it's quite 
        legitimate to put the mapping in the substitution anyway.
                a77 -> a77
        from the substitution, when we decide not to clone a77, but it's quite 
        legitimate to put the mapping in the substitution anyway.

-       
-       Indeed, we do so when we want to pass fragile OccInfo to the
-       occurrences of the variable; we add a substitution
-               x77 -> DoneId x77 occ
-       to record x's occurrence information.]

 
        Furthermore, consider 
                let x = case k of I# x77 -> ... in
 
        Furthermore, consider 
                let x = case k of I# x77 -> ... in

@@ -165,12 +183,9 @@ seIdSubst:
        Of course, the substitution *must* applied! Things in its domain 
        simply aren't necessarily bound in the result.
 
        Of course, the substitution *must* applied! Things in its domain 
        simply aren't necessarily bound in the result.
 

-* substId adds a binding (DoneId new_id occ) to the substitution if 
-       EITHER the Id's unique has changed
-       OR     the Id has interesting occurrence information
-  So in effect you can only get to interesting occurrence information
-  by looking up the *old* Id; it's not really attached to the new id
-  at all.
+* substId adds a binding (DoneId new_id) to the substitution if 
+       the Id's unique has changed
+

 
   Note, though that the substitution isn't necessarily extended
   if the type changes.  Why not?  Because of the next point:
 
   Note, though that the substitution isn't necessarily extended
   if the type changes.  Why not?  Because of the next point:

@@ -197,44 +212,12 @@ seIdSubst:
   That's why the "set" is actually a VarEnv Var
 
 
   That's why the "set" is actually a VarEnv Var
 
 

-Note [GADT type refinement]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When we come to a GADT pattern match that refines the in-scope types, we
-  a) Refine the types of the Ids in the in-scope set, seInScope.  
-     For exmaple, consider
-       data T a where
-               Foo :: T (Bool -> Bool)
-
-       (\ (x::T a) (y::a) -> case x of { Foo -> y True }
-
-     Technically this is well-typed, but exprType will barf on the
-     (y True) unless we refine the type on y's occurrence.
-
-  b) Refine the range of the type substitution, seTvSubst. 
-     Very similar reason to (a).
-
-  NB: we don't refine the range of the SimplIdSubst, because it's always
-  interpreted relative to the seInScope (see substId)
-
-For (b) we need to be a little careful.  Specifically, we compose the refinement 
-with the type substitution.  Suppose 
-  The substitution was   [a->b, b->a]
-  and the refinement was  [b->Int]
-  Then we want [a->Int, b->a]
-
-But also if
-  The substitution was   [a->b]
-  and the refinement was  [b->Int]
-  Then we want [a->Int, b->Int]
-       becuase b might be both an InTyVar and OutTyVar
-
-

 \begin{code}
 \begin{code}

-mkSimplEnv :: SimplifierMode -> SwitchChecker -> RuleBase -> SimplEnv
-mkSimplEnv mode switches rules
+mkSimplEnv :: SimplifierMode -> SwitchChecker -> SimplEnv
+mkSimplEnv mode switches

   = SimplEnv { seChkr = switches, seCC = subsumedCCS, 
               seMode = mode, seInScope = emptyInScopeSet, 
   = SimplEnv { seChkr = switches, seCC = subsumedCCS, 
               seMode = mode, seInScope = emptyInScopeSet, 

-              seExtRules = rules,
+              seFloats = emptyFloats,

               seTvSubst = emptyVarEnv, seIdSubst = emptyVarEnv }
        -- The top level "enclosing CC" is "SUBSUMED".
 
               seTvSubst = emptyVarEnv, seIdSubst = emptyVarEnv }
        -- The top level "enclosing CC" is "SUBSUMED".
 

@@ -273,7 +256,16 @@ setInScopeSet :: SimplEnv -> InScopeSet -> SimplEnv
 setInScopeSet env in_scope = env {seInScope = in_scope}
 
 setInScope :: SimplEnv -> SimplEnv -> SimplEnv
 setInScopeSet env in_scope = env {seInScope = in_scope}
 
 setInScope :: SimplEnv -> SimplEnv -> SimplEnv

-setInScope env env_with_in_scope = setInScopeSet env (getInScope env_with_in_scope)
+-- Set the in-scope set, and *zap* the floats
+setInScope env env_with_scope
+  = env { seInScope = seInScope env_with_scope,
+         seFloats = emptyFloats }
+
+setFloats :: SimplEnv -> SimplEnv -> SimplEnv
+-- Set the in-scope set *and* the floats
+setFloats env env_with_floats
+  = env { seInScope = seInScope env_with_floats,
+         seFloats  = seFloats  env_with_floats }

 
 addNewInScopeIds :: SimplEnv -> [CoreBndr] -> SimplEnv
        -- The new Ids are guaranteed to be freshly allocated
 
 addNewInScopeIds :: SimplEnv -> [CoreBndr] -> SimplEnv
        -- The new Ids are guaranteed to be freshly allocated

@@ -303,38 +295,158 @@ mkContEx (SimplEnv { seTvSubst = tvs, seIdSubst = ids }) e = ContEx tvs ids e
 isEmptySimplSubst :: SimplEnv -> Bool
 isEmptySimplSubst (SimplEnv { seTvSubst = tvs, seIdSubst = ids })
   = isEmptyVarEnv tvs && isEmptyVarEnv ids
 isEmptySimplSubst :: SimplEnv -> Bool
 isEmptySimplSubst (SimplEnv { seTvSubst = tvs, seIdSubst = ids })
   = isEmptyVarEnv tvs && isEmptyVarEnv ids

-
----------------------
-getRules :: SimplEnv -> RuleBase
-getRules = seExtRules

 \end{code}
 
 \end{code}
 

-               GADT stuff

 
 

-Given an idempotent substitution, generated by the unifier, use it to 
-refine the environment
+
+%************************************************************************
+%*                                                                     *
+\subsection{Floats}
+%*                                                                     *
+%************************************************************************
+
+Note [Simplifier floats]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+The Floats is a bunch of bindings, classified by a FloatFlag.
+
+  NonRec x (y:ys)      FltLifted
+  Rec [(x,rhs)]                FltLifted
+
+  NonRec x# (y +# 3)   FltOkSpec       -- Unboxed, but ok-for-spec'n
+
+  NonRec x# (a /# b)   FltCareful
+  NonRec x* (f y)      FltCareful      -- Strict binding; might fail or diverge
+  NonRec x# (f y)      FltCareful      -- Unboxed binding: might fail or diverge
+                                       --        (where f :: Int -> Int#)

 
 \begin{code}
 
 \begin{code}

-refineSimplEnv :: SimplEnv -> TypeRefinement -> SimplEnv
--- The TvSubstEnv is the refinement, and it refines OutTyVars into OutTypes
-refineSimplEnv env@(SimplEnv { seTvSubst = tv_subst, seInScope = in_scope })
-              (refine_tv_subst, all_bound_here)
-  = env { seTvSubst = composeTvSubst in_scope refine_tv_subst tv_subst,
-         seInScope = in_scope' }
+data Floats = Floats (OrdList OutBind) FloatFlag
+       -- See Note [Simplifier floats]
+
+data FloatFlag
+  = FltLifted  -- All bindings are lifted and lazy
+               --  Hence ok to float to top level, or recursive
+
+  | FltOkSpec  -- All bindings are FltLifted *or* 
+               --      strict (perhaps because unlifted, 
+               --      perhaps because of a strict binder),
+               --        *and* ok-for-speculation
+               --  Hence ok to float out of the RHS 
+               --  of a lazy non-recursive let binding
+               --  (but not to top level, or into a rec group)
+
+  | FltCareful -- At least one binding is strict (or unlifted)
+               --      and not guaranteed cheap
+               --      Do not float these bindings out of a lazy let
+
+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")
+   
+andFF :: FloatFlag -> FloatFlag -> FloatFlag
+andFF FltCareful _         = FltCareful
+andFF FltOkSpec  FltCareful = FltCareful
+andFF FltOkSpec  flt       = FltOkSpec
+andFF FltLifted  flt       = flt
+
+classifyFF :: CoreBind -> FloatFlag
+classifyFF (Rec _) = FltLifted
+classifyFF (NonRec bndr rhs) 
+  | not (isStrictId bndr)    = FltLifted
+  | exprOkForSpeculation rhs = FltOkSpec
+  | otherwise               = FltCareful
+
+doFloatFromRhs :: TopLevelFlag -> RecFlag -> Bool -> OutExpr -> SimplEnv -> Bool
+doFloatFromRhs lvl rec str rhs (SimplEnv {seFloats = Floats fs ff}) 
+  =  not (isNilOL fs) && want_to_float && can_float

   where
   where

-    in_scope' 
-       | all_bound_here = in_scope
-               -- The tvs are the tyvars bound here.  If only they 
-               -- are refined, there's no need to do anything 
-       | otherwise = mapInScopeSet refine_id in_scope
-
-    refine_id v        -- Only refine its type; any rules will get
-                       -- refined if they are used (I hope)
-       | isId v    = setIdType v (Type.substTy refine_subst (idType v))
-       | otherwise = v
-    refine_subst = TvSubst in_scope refine_tv_subst
+     want_to_float = isTopLevel lvl || exprIsCheap rhs
+     can_float = case ff of
+                  FltLifted  -> True
+                  FltOkSpec  -> isNotTopLevel lvl && isNonRec rec
+                  FltCareful -> isNotTopLevel lvl && isNonRec rec && str

 \end{code}
 
 \end{code}
 

+
+\begin{code}
+emptyFloats :: Floats
+emptyFloats = Floats nilOL FltLifted
+
+unitFloat :: OutBind -> Floats
+-- A single-binding float
+unitFloat bind = Floats (unitOL bind) (classifyFF bind)
+
+addNonRec :: SimplEnv -> OutId -> OutExpr -> SimplEnv
+-- Add a non-recursive binding and extend the in-scope set
+-- The latter is important; the binder may already be in the
+-- in-scope set (although it might also have been created with newId)
+-- but it may now have more IdInfo
+addNonRec env id rhs
+  = env { seFloats = seFloats env `addFlts` unitFloat (NonRec id rhs),
+         seInScope = extendInScopeSet (seInScope env) id }
+
+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,
+         seInScope = extendInScopeSetList (seInScope env) bndrs }
+  where
+    bndrs = bindersOfBinds binds
+    new_floats = Floats (toOL binds) 
+                       (foldr (andFF . classifyFF) FltLifted binds)
+
+addFloats :: SimplEnv -> SimplEnv -> SimplEnv
+-- Add the floats for env2 to env1; 
+-- *plus* the in-scope set for env2, which is bigger 
+-- than that for env1
+addFloats env1 env2 
+  = env1 {seFloats = seFloats env1 `addFlts` seFloats env2,
+         seInScope = seInScope env2 }
+
+addFlts :: Floats -> Floats -> Floats
+addFlts (Floats bs1 l1) (Floats bs2 l2)
+  = Floats (bs1 `appOL` bs2) (l1 `andFF` l2)
+
+zapFloats :: SimplEnv -> SimplEnv
+zapFloats env = env { seFloats = emptyFloats }
+
+addRecFloats :: SimplEnv -> SimplEnv -> SimplEnv
+-- Flattens the floats from env2 into a single Rec group,
+-- prepends the floats from env1, and puts the result back in env2
+-- 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) )
+    env2 {seFloats = seFloats env1 `addFlts` unitFloat (Rec (flattenBinds (fromOL bs)))}
+
+wrapFloats :: SimplEnv -> OutExpr -> OutExpr
+wrapFloats env expr = wrapFlts (seFloats env) expr
+
+wrapFlts :: Floats -> OutExpr -> OutExpr
+-- Wrap the floats around the expression, using case-binding where necessary
+wrapFlts (Floats bs _) body = foldrOL wrap body bs
+  where
+    wrap (Rec prs)    body = Let (Rec prs) body
+    wrap (NonRec b r) body = bindNonRec b r body
+
+getFloats :: SimplEnv -> [CoreBind]
+getFloats (SimplEnv {seFloats = Floats bs _}) = fromOL bs
+
+isEmptyFloats :: SimplEnv -> Bool
+isEmptyFloats env = isEmptyFlts (seFloats env)
+
+isEmptyFlts :: Floats -> Bool
+isEmptyFlts (Floats bs _) = isNilOL bs 
+
+floatBinds :: Floats -> [OutBind]
+floatBinds (Floats bs _) = fromOL bs
+\end{code}
+
+

 %************************************************************************
 %*                                                                     *
                Substitution of Vars
 %************************************************************************
 %*                                                                     *
                Substitution of Vars

@@ -346,27 +458,29 @@ refineSimplEnv env@(SimplEnv { seTvSubst = tv_subst, seInScope = in_scope })
 substId :: SimplEnv -> Id -> SimplSR
 substId (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v 
   | not (isLocalId v) 
 substId :: SimplEnv -> Id -> SimplSR
 substId (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v 
   | not (isLocalId v) 

-  = DoneId v NoOccInfo
+  = DoneId v

   | otherwise  -- A local Id
   = case lookupVarEnv ids v of
   | otherwise  -- A local Id
   = case lookupVarEnv ids v of

-       Just (DoneId v occ) -> DoneId (refine v) occ
-       Just res            -> res
-       Nothing             -> let v' = refine v
-                              in DoneId v' (idOccInfo v')
-               -- We don't put LoopBreakers in the substitution (unless then need
-               -- to be cloned for name-clash rasons), so the idOccInfo is
-               -- very important!  If isFragileOcc returned True for
-               -- loop breakers we could avoid this call, but at the expense
-               -- of adding more to the substitution, and building new Ids
-               -- a bit more often than really necessary
+       Just (DoneId v) -> DoneId (refine in_scope v)
+       Just res        -> res
+       Nothing         -> DoneId (refine in_scope v)

   where
   where

+

        -- Get the most up-to-date thing from the in-scope set
        -- Even though it isn't in the substitution, it may be in
        -- 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 a different type (we only use the
-       -- substitution if the unique changes).
-    refine v = case lookupInScope in_scope v of
-                Just v' -> v'
-                Nothing -> WARN( True, ppr v ) v       -- This is an error!
+       -- the in-scope set with better IdInfo
+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
+-- 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
+  = case lookupVarEnv ids v of
+       Just (DoneId v) -> v
+       Just res        -> pprPanic "lookupRecBndr" (ppr v)
+       Nothing         -> refine in_scope v

 \end{code}
 
 
 \end{code}
 
 

@@ -381,12 +495,12 @@ These functions are in the monad only so that they can be made strict via seq.
 
 \begin{code}
 simplBinders, simplLamBndrs
 
 \begin{code}
 simplBinders, simplLamBndrs

-       :: SimplEnv -> [InBinder] -> SimplM (SimplEnv, [OutBinder])
+       :: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [OutBndr])

 simplBinders  env bndrs = mapAccumLSmpl simplBinder  env bndrs
 simplLamBndrs env bndrs = mapAccumLSmpl simplLamBndr env bndrs
 
 -------------
 simplBinders  env bndrs = mapAccumLSmpl simplBinder  env bndrs
 simplLamBndrs env bndrs = mapAccumLSmpl simplLamBndr env bndrs
 
 -------------

-simplBinder :: SimplEnv -> InBinder -> SimplM (SimplEnv, OutBinder)
+simplBinder :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)

 -- Used for lambda and case-bound variables
 -- Clone Id if necessary, substitute type
 -- Return with IdInfo already substituted, but (fragile) occurrence info zapped
 -- Used for lambda and case-bound variables
 -- Clone Id if necessary, substitute type
 -- Return with IdInfo already substituted, but (fragile) occurrence info zapped

@@ -428,6 +542,8 @@ substIdBndr :: SimplEnv -> Id       -- Substitition and Id to transform
 --     * The substitution extended with a DoneId if unique changed
 --       In this case, the var in the DoneId is the same as the
 --       var returned
 --     * The substitution extended with a DoneId if unique changed
 --       In this case, the var in the DoneId is the same as the
 --       var returned

+--
+-- Exactly like CoreSubst.substIdBndr, except that the type of id_subst differs

 
 substIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst})
            old_id
 
 substIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst})
            old_id

@@ -442,18 +558,19 @@ substIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst})
 
        -- new_id has the final IdInfo
     subst  = mkCoreSubst env
 
        -- new_id has the final IdInfo
     subst  = mkCoreSubst env

-    new_id = maybeModifyIdInfo (substIdInfo subst) id2
+    new_id = maybeModifyIdInfo (substIdInfo subst (idInfo old_id)) id2

 
        -- Extend the substitution if the unique has changed
        -- See the notes with substTyVarBndr for the delSubstEnv
 
        -- Extend the substitution if the unique has changed
        -- See the notes with substTyVarBndr for the delSubstEnv

+       -- Also see Note [Extending the Subst] in CoreSubst

     new_subst | new_id /= old_id
     new_subst | new_id /= old_id

-             = extendVarEnv id_subst old_id (DoneId new_id (idOccInfo old_id))
+             = extendVarEnv id_subst old_id (DoneId new_id)

              | otherwise 
              = delVarEnv id_subst old_id
 \end{code}
 
              | otherwise 
              = delVarEnv id_subst old_id
 \end{code}
 

-

 \begin{code}
 \begin{code}

+------------------------------------

 seqTyVar :: TyVar -> ()
 seqTyVar b = b `seq` ()
 
 seqTyVar :: TyVar -> ()
 seqTyVar b = b `seq` ()
 

@@ -467,7 +584,6 @@ seqIds []       = ()
 seqIds (id:ids) = seqId id `seq` seqIds ids
 \end{code}
 
 seqIds (id:ids) = seqId id `seq` seqIds ids
 \end{code}
 

-

 %************************************************************************
 %*                                                                     *
                Let bindings
 %************************************************************************
 %*                                                                     *
                Let bindings

@@ -479,24 +595,28 @@ Simplifying let binders
 Rename the binders if necessary, 
 
 \begin{code}
 Rename the binders if necessary, 
 
 \begin{code}

-simplNonRecBndr :: SimplEnv -> InBinder -> SimplM (SimplEnv, OutBinder)
+simplNonRecBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)

 simplNonRecBndr env id
   = do { let (env1, id1) = substLetIdBndr env id
        ; seqId id1 `seq` return (env1, id1) }
 
 ---------------
 simplNonRecBndr env id
   = do { let (env1, id1) = substLetIdBndr env id
        ; seqId id1 `seq` return (env1, id1) }
 
 ---------------

-simplRecBndrs :: SimplEnv -> [InBinder] -> SimplM (SimplEnv, [OutBinder])
+simplRecBndrs :: SimplEnv -> [InBndr] -> SimplM SimplEnv

 simplRecBndrs env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) ids
   = do { let (env1, ids1) = mapAccumL substLetIdBndr env ids
 simplRecBndrs env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) ids
   = do { let (env1, ids1) = mapAccumL substLetIdBndr env ids

-       ; seqIds ids1 `seq` return (env1, ids1) }
+       ; seqIds ids1 `seq` return env1 }

 
 ---------------
 
 ---------------

-substLetIdBndr :: SimplEnv -> InBinder         -- Env and binder to transform
-              -> (SimplEnv, OutBinder)
--- C.f. CoreSubst.substIdBndr
+substLetIdBndr :: SimplEnv -> InBndr   -- Env and binder to transform
+              -> (SimplEnv, OutBndr)
+-- C.f. substIdBndr above

 -- Clone Id if necessary, substitute its type
 -- Clone Id if necessary, substitute its type

--- Return an Id with completely zapped IdInfo
+-- Return an Id with its fragile info zapped
+--     namely, any info that depends on free variables

 --     [addLetIdInfo, below, will restore its IdInfo]
 --     [addLetIdInfo, below, will restore its IdInfo]

+--     We want to retain robust info, especially arity and demand info,
+--     so that they are available to occurrences that occur in an
+--     earlier binding of a letrec

 -- Augment the subtitution 
 --     if the unique changed, *or* 
 --     if there's interesting occurrence info
 -- Augment the subtitution 
 --     if the unique changed, *or* 
 --     if there's interesting occurrence info

@@ -507,20 +627,22 @@ substLetIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) old
   where
     id1           = uniqAway in_scope old_id
     id2    = substIdType env id1
   where
     id1           = uniqAway in_scope old_id
     id2    = substIdType env id1

-    new_id = setIdInfo id2 vanillaIdInfo
+
+    -- We want to get rid of any info that's dependent on free variables,
+    -- but keep other info (like the arity).
+    new_id = zapFragileIdInfo id2

 
        -- Extend the substitution if the unique has changed,
        -- or there's some useful occurrence information
        -- See the notes with substTyVarBndr for the delSubstEnv
 
        -- Extend the substitution if the unique has changed,
        -- or there's some useful occurrence information
        -- See the notes with substTyVarBndr for the delSubstEnv

-    occ_info = occInfo (idInfo old_id)
-    new_subst | new_id /= old_id || isFragileOcc occ_info
-             = extendVarEnv id_subst old_id (DoneId new_id occ_info)
+    new_subst | new_id /= old_id
+             = extendVarEnv id_subst old_id (DoneId new_id)

              | otherwise 
              = delVarEnv id_subst old_id
 \end{code}
 
              | otherwise 
              = delVarEnv id_subst old_id
 \end{code}
 

-Add IdInfo back onto a let-bound Id
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Note [Add IdInfo back onto a let-bound Id]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

 We must transfer the IdInfo of the original binder to the new binder.
 This is crucial, to preserve
        strictness
 We must transfer the IdInfo of the original binder to the new binder.
 This is crucial, to preserve
        strictness

@@ -535,19 +657,34 @@ This is important.  Manuel found cases where he really, really
 wanted a RULE for a recursive function to apply in that function's
 own right-hand side.
 
 wanted a RULE for a recursive function to apply in that function's
 own right-hand side.
 

-NB 2: We do not transfer the arity (see Subst.substIdInfo)
-The arity of an Id should not be visible
-in its own RHS, else we eta-reduce
+NB 2: ARITY.  We *do* transfer the arity.  This is important, so that
+the arity of an Id is visible in its own RHS.  For example:
+       f = \x. ....g (\y. f y)....
+We can eta-reduce the arg to g, becuase f is a value.  But that 
+needs to be visible.  
+
+This interacts with the 'state hack' too:
+       f :: Bool -> IO Int
+       f = \x. case x of 
+                 True  -> f y
+                 False -> \s -> ...
+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
+allows us to eta-reduce

        f = \x -> f x
 to
        f = f
        f = \x -> f x
 to
        f = f

-which isn't sound.  And it makes the arity in f's IdInfo greater than
-the manifest arity, which isn't good.
-The arity will get added later.
+which technically is not sound.   This is very much a corner case, so
+I'm not worried about it.  Another idea is to ensure that f's arity 
+never decreases; its arity started as 1, and we should never eta-reduce
+below that.

 
 

-NB 3: It's important that we *do* transer the loop-breaker OccInfo,
-because that's what stops the Id getting inlined infinitely, in the body
-of the letrec.
+NB 3: OccInfo.  It's important that we *do* transer the loop-breaker
+OccInfo, because that's what stops the Id getting inlined infinitely,
+in the body of the letrec.

 
 NB 4: does no harm for non-recursive bindings
 
 
 NB 4: does no harm for non-recursive bindings
 

@@ -560,9 +697,9 @@ Here, we'll do postInlineUnconditionally on f, and we must "see" that
 when substituting in h's RULE.  
 
 \begin{code}
 when substituting in h's RULE.  
 
 \begin{code}

-addLetIdInfo :: SimplEnv -> InBinder -> OutBinder -> (SimplEnv, OutBinder)
+addLetIdInfo :: SimplEnv -> InBndr -> OutBndr -> (SimplEnv, OutBndr)

 addLetIdInfo env in_id out_id
 addLetIdInfo env in_id out_id

-  = (modifyInScope env out_id out_id, final_id)
+  = (modifyInScope env out_id final_id, final_id)

   where
     final_id = out_id `setIdInfo` new_info
     subst = mkCoreSubst env
   where
     final_id = out_id `setIdInfo` new_info
     subst = mkCoreSubst env

@@ -577,7 +714,7 @@ substIdInfo :: CoreSubst.Subst -> IdInfo -> Maybe IdInfo
 --     worker info
 -- Zap the unfolding 
 -- Keep only 'robust' OccInfo
 --     worker info
 -- Zap the unfolding 
 -- Keep only 'robust' OccInfo

--- Zap Arity
+--          arity

 -- 
 -- Seq'ing on the returned IdInfo is enough to cause all the 
 -- substitutions to happen completely
 -- 
 -- Seq'ing on the returned IdInfo is enough to cause all the 
 -- substitutions to happen completely

@@ -585,21 +722,18 @@ substIdInfo :: CoreSubst.Subst -> IdInfo -> Maybe IdInfo
 substIdInfo subst info
   | nothing_to_do = Nothing
   | otherwise     = Just (info `setOccInfo`              (if keep_occ then old_occ else NoOccInfo)
 substIdInfo subst info
   | nothing_to_do = Nothing
   | otherwise     = Just (info `setOccInfo`              (if keep_occ then old_occ else NoOccInfo)

-                              `setArityInfo`     (if keep_arity then old_arity else unknownArity)

                               `setSpecInfo`      CoreSubst.substSpec   subst old_rules
                               `setWorkerInfo`    CoreSubst.substWorker subst old_wrkr
                               `setUnfoldingInfo` noUnfolding)
                        -- setSpecInfo does a seq
                        -- setWorkerInfo does a seq
   where
                               `setSpecInfo`      CoreSubst.substSpec   subst old_rules
                               `setWorkerInfo`    CoreSubst.substWorker subst old_wrkr
                               `setUnfoldingInfo` noUnfolding)
                        -- setSpecInfo does a seq
                        -- setWorkerInfo does a seq
   where

-    nothing_to_do = keep_occ && keep_arity &&
+    nothing_to_do = keep_occ && 

                    isEmptySpecInfo old_rules &&
                    not (workerExists old_wrkr) &&
                    not (hasUnfolding (unfoldingInfo info))
     
                    isEmptySpecInfo old_rules &&
                    not (workerExists old_wrkr) &&
                    not (hasUnfolding (unfoldingInfo info))
     

-    keep_occ   = not (isFragileOcc old_occ)
-    keep_arity = old_arity == unknownArity
-    old_arity = arityInfo info
+    keep_occ  = not (isFragileOcc old_occ)

     old_occ   = occInfo info
     old_rules = specInfo info
     old_wrkr  = workerInfo info
     old_occ   = occInfo info
     old_rules = specInfo info
     old_wrkr  = workerInfo info

@@ -608,7 +742,7 @@ substIdInfo subst info
 substIdType :: SimplEnv -> Id -> Id
 substIdType env@(SimplEnv { seInScope = in_scope,  seTvSubst = tv_env}) id
   | isEmptyVarEnv tv_env || isEmptyVarSet (tyVarsOfType old_ty) = id
 substIdType :: SimplEnv -> Id -> Id
 substIdType env@(SimplEnv { seInScope = in_scope,  seTvSubst = tv_env}) id
   | isEmptyVarEnv tv_env || isEmptyVarSet (tyVarsOfType old_ty) = id

-  | otherwise  = setIdType id (Type.substTy (TvSubst in_scope tv_env) old_ty)
+  | otherwise  = Id.setIdType id (Type.substTy (TvSubst in_scope tv_env) old_ty)

                -- The tyVarsOfType is cheaper than it looks
                -- because we cache the free tyvars of the type
                -- in a Note in the id's type itself
                -- The tyVarsOfType is cheaper than it looks
                -- because we cache the free tyvars of the type
                -- in a Note in the id's type itself

@@ -652,7 +786,7 @@ mkCoreSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seIdSubst = id
     mk_subst tv_env id_env = CoreSubst.mkSubst in_scope tv_env (mapVarEnv fiddle id_env)
 
     fiddle (DoneEx e)       = e
     mk_subst tv_env id_env = CoreSubst.mkSubst in_scope tv_env (mapVarEnv fiddle id_env)
 
     fiddle (DoneEx e)       = e

-    fiddle (DoneId v occ)   = Var v
+    fiddle (DoneId v)       = Var v

     fiddle (ContEx tv id e) = CoreSubst.substExpr (mk_subst tv id) e
 
 substExpr :: SimplEnv -> CoreExpr -> CoreExpr
     fiddle (ContEx tv id e) = CoreSubst.substExpr (mk_subst tv id) e
 
 substExpr :: SimplEnv -> CoreExpr -> CoreExpr

@@ -661,81 +795,3 @@ substExpr env expr
   | otherwise            = CoreSubst.substExpr (mkCoreSubst env) expr
 \end{code}
 
   | otherwise            = CoreSubst.substExpr (mkCoreSubst env) expr
 \end{code}
 

-
-%************************************************************************
-%*                                                                     *
-\subsection{Floats}
-%*                                                                     *
-%************************************************************************
-
-\begin{code}
-type FloatsWithExpr = FloatsWith OutExpr
-type FloatsWith a   = (Floats, 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
-
-data Floats = Floats (OrdList OutBind) 
-                    InScopeSet         -- Environment "inside" all the floats
-                    Bool               -- True <=> All bindings are lifted
-
-allLifted :: Floats -> Bool
-allLifted (Floats _ _ is_lifted) = is_lifted
-
-wrapFloats :: Floats -> OutExpr -> OutExpr
-wrapFloats (Floats bs _ _) body = foldrOL Let body bs
-
-isEmptyFloats :: Floats -> Bool
-isEmptyFloats (Floats bs _ _) = isNilOL bs 
-
-floatBinds :: Floats -> [OutBind]
-floatBinds (Floats bs _ _) = fromOL bs
-
-flattenFloats :: Floats -> Floats
--- Flattens into a single Rec group
-flattenFloats (Floats bs is is_lifted) 
-  = ASSERT2( is_lifted, ppr (fromOL bs) )
-    Floats (unitOL (Rec (flattenBinds (fromOL bs)))) is is_lifted
-\end{code}
-
-\begin{code}
-emptyFloats :: SimplEnv -> Floats
-emptyFloats env = Floats nilOL (getInScope env) True
-
-unitFloat :: SimplEnv -> OutId -> OutExpr -> Floats
--- A single non-rec float; extend the in-scope set
-unitFloat env var rhs = Floats (unitOL (NonRec var rhs))
-                              (extendInScopeSet (getInScope env) var)
-                              (not (isUnLiftedType (idType var)))
-
-addFloats :: SimplEnv -> Floats 
-         -> (SimplEnv -> SimplM (FloatsWith a))
-         -> SimplM (FloatsWith a)
-addFloats env (Floats b1 is1 l1) thing_inside
-  | isNilOL b1 
-  = thing_inside env
-  | otherwise
-  = thing_inside (setInScopeSet env is1)       `thenSmpl` \ (Floats b2 is2 l2, res) ->
-    returnSmpl (Floats (b1 `appOL` b2) is2 (l1 && l2), res)
-
-addLetBind :: OutBind -> Floats -> Floats
-addLetBind bind (Floats binds in_scope lifted) 
-  = Floats (bind `consOL` binds) in_scope (lifted && is_lifted_bind bind)
-
-is_lifted_bind (Rec _)      = True
-is_lifted_bind (NonRec b r) = not (isUnLiftedType (idType b))
-
--- addAuxiliaryBind    * takes already-simplified things (bndr and rhs)
---                     * extends the in-scope env
---                     * assumes it's a let-bindable thing
-addAuxiliaryBind :: SimplEnv -> OutBind
-                -> (SimplEnv -> SimplM (FloatsWith a))
-                -> SimplM (FloatsWith a)
-       -- Extends the in-scope environment as well as wrapping the bindings
-addAuxiliaryBind env bind thing_inside
-  = ASSERT( case bind of { NonRec b r -> not (needsCaseBinding (idType b) r) ; Rec _ -> True } )
-    thing_inside (addNewInScopeIds env (bindersOf bind))       `thenSmpl` \ (floats, x) ->
-    returnSmpl (addLetBind bind floats, x)
-\end{code}
-
-