Undo patch Simplify-the-IdInfo-before-any-RHSs
[ghc-hetmet.git] / ghc / compiler / simplCore / SimplEnv.lhs
index 6656d56..00f035e 100644 (file)
@@ -1,93 +1,69 @@
 %
-% (c) The AQUA Project, Glasgow University, 1993-1996
+% (c) The AQUA Project, Glasgow University, 1993-1998
 %
-\section[SimplEnv]{Environment stuff for the simplifier}
+\section[SimplMonad]{The simplifier Monad}
 
 \begin{code}
-#include "HsVersions.h"
-
 module SimplEnv (
-       nullSimplEnv, combineSimplEnv,
-       pprSimplEnv, -- debugging only
-
-       extendTyEnv, extendTyEnvList,
-       simplTy, simplTyInId,
-
-       extendIdEnvWithAtom, extendIdEnvWithAtoms,
-       extendIdEnvWithClone, extendIdEnvWithClones,
-       lookupId,
-
+       InId, InBind, InExpr, InAlt, InArg, InType, InBinder,
+       OutId, OutTyVar, OutBind, OutExpr, OutAlt, OutArg, OutType, OutBinder,
 
-       markDangerousOccs,
-       lookupRhsInfo, lookupOutIdEnv, isEvaluated,
-       extendEnvGivenBinding, extendEnvGivenNewRhs,
-       extendEnvGivenRhsInfo,
+       -- The simplifier mode
+       setMode, getMode, 
 
-       lookForConstructor,
-
-       getSwitchChecker, switchIsSet, getSimplIntSwitch, 
-       switchOffInlining, setCaseScrutinee,
+       -- Switch checker
+       SwitchChecker, SwitchResult(..), getSwitchChecker, getSimplIntSwitch,
+       isAmongSimpl, intSwitchSet, switchIsOn,
 
        setEnclosingCC, getEnclosingCC,
 
-       -- Types
-       SYN_IE(SwitchChecker),
-       SimplEnv, 
-       SYN_IE(InIdEnv), SYN_IE(InTypeEnv),
-       UnfoldConApp,
-       RhsInfo(..),
+       -- Environments
+       SimplEnv, mkSimplEnv, extendIdSubst, extendTvSubst, 
+       zapSubstEnv, setSubstEnv, 
+       getInScope, setInScope, setInScopeSet, modifyInScope, addNewInScopeIds,
+       getRules, refineSimplEnv,
 
-       SYN_IE(InId),  SYN_IE(InBinder),  SYN_IE(InBinding),  SYN_IE(InType),
-       SYN_IE(OutId), SYN_IE(OutBinder), SYN_IE(OutBinding), SYN_IE(OutType),
+       SimplSR(..), mkContEx, substId, 
 
-       SYN_IE(InExpr),  SYN_IE(InAlts),  SYN_IE(InDefault),  SYN_IE(InArg),
-       SYN_IE(OutExpr), SYN_IE(OutAlts), SYN_IE(OutDefault), SYN_IE(OutArg)
-    ) where
+       simplNonRecBndr, simplRecBndrs, simplLamBndr, simplLamBndrs, 
+       simplBinder, simplBinders, addLetIdInfo,
+       substExpr, substTy,
 
-IMP_Ubiq(){-uitous-}
+       -- Floats
+       FloatsWith, FloatsWithExpr,
+       Floats, emptyFloats, isEmptyFloats, unitFloat, addFloats, flattenFloats,
+       allLifted, wrapFloats, floatBinds,
+       addAuxiliaryBind,
+    ) where
 
-IMPORT_DELOOPER(SmplLoop)              -- breaks the MagicUFs / SimplEnv loop
+#include "HsVersions.h"
 
-import BinderInfo      ( orBinderInfo, andBinderInfo, noBinderInfo,
-                         BinderInfo(..){-instances, too-}, FunOrArg, DuplicationDanger, InsideSCC
-                       )
-import CmdLineOpts     ( switchIsOn, intSwitchSet, opt_UnfoldingCreationThreshold,
-                         SimplifierSwitch(..), SwitchResult(..)
-                       )
+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 CoreSyn
-import CoreUnfold      ( mkFormSummary, exprSmallEnoughToDup, 
-                         Unfolding(..), UfExpr, RdrName,
-                         SimpleUnfolding(..), FormSummary(..),
-                         calcUnfoldingGuidance, UnfoldingGuidance(..)
-                       )
-import CoreUtils       ( coreExprCc, unTagBinders )
-import CostCentre      ( CostCentre, noCostCentre, noCostCentreAttached )
-import FiniteMap       -- lots of things
-import Id              ( idType, getIdUnfolding, getIdStrictness, idWantsToBeINLINEd,
-                         applyTypeEnvToId, getInlinePragma,
-                         nullIdEnv, growIdEnvList, rngIdEnv, lookupIdEnv,
-                         addOneToIdEnv, modifyIdEnv, mkIdSet, modifyIdEnv_Directly,
-                         SYN_IE(IdEnv), SYN_IE(IdSet), GenId, SYN_IE(Id) )
-import Literal         ( isNoRepLit, Literal{-instances-} )
-import Maybes          ( maybeToBool, expectJust )
-import Name            ( isLocallyDefined )
-import OccurAnal       ( occurAnalyseExpr )
-import Outputable      ( PprStyle(..), Outputable(..){-instances-} )
-import PprCore         -- various instances
-import PprType         ( GenType, GenTyVar )
-import Pretty
-import Type            ( eqTy, applyTypeEnvToTy, SYN_IE(Type) )
-import TyVar           ( nullTyVarEnv, addOneToTyVarEnv, growTyVarEnvList,
-                         SYN_IE(TyVarEnv), GenTyVar{-instance Eq-} ,
-                         SYN_IE(TyVar)
-                       )
-import Unique          ( Unique{-instance Outputable-} )
-import UniqFM          ( addToUFM_C, ufmToList, Uniquable(..)
-                       )
-import Usage           ( SYN_IE(UVar), GenUsage{-instances-} )
-import Util            ( SYN_IE(Eager), appEager, returnEager, runEager,
-                         zipEqual, thenCmp, cmpList, panic, panic#, assertPanic, Ord3(..) )
-
+import Unify           ( TypeRefinement )
+import Rules           ( RuleBase )
+import CoreUtils       ( needsCaseBinding )
+import CostCentre      ( CostCentreStack, subsumedCCS )
+import Var     
+import VarEnv
+import VarSet          ( isEmptyVarSet )
+import OrdList
+
+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 Outputable
 \end{code}
 
 %************************************************************************
@@ -97,25 +73,22 @@ import Util         ( SYN_IE(Eager), appEager, returnEager, runEager,
 %************************************************************************
 
 \begin{code}
+type InBinder  = CoreBndr
 type InId      = Id                    -- Not yet cloned
-type InBinder  = (InId, BinderInfo)
 type InType    = Type                  -- Ditto
-type InBinding = SimplifiableCoreBinding
-type InExpr    = SimplifiableCoreExpr
-type InAlts    = SimplifiableCoreCaseAlts
-type InDefault = SimplifiableCoreCaseDefault
-type InArg     = SimplifiableCoreArg
+type InBind    = CoreBind
+type InExpr    = CoreExpr
+type InAlt     = CoreAlt
+type InArg     = CoreArg
 
+type OutBinder  = CoreBndr
 type OutId     = Id                    -- Cloned
-type OutBinder = Id
+type OutTyVar  = TyVar                 -- Cloned
 type OutType   = Type                  -- Cloned
-type OutBinding        = CoreBinding
+type OutBind   = CoreBind
 type OutExpr   = CoreExpr
-type OutAlts   = CoreCaseAlts
-type OutDefault        = CoreCaseDefault
+type OutAlt    = CoreAlt
 type OutArg    = CoreArg
-
-type SwitchChecker = SimplifierSwitch -> SwitchResult
 \end{code}
 
 %************************************************************************
@@ -125,660 +98,644 @@ type SwitchChecker = SimplifierSwitch -> SwitchResult
 %************************************************************************
 
 
-INVARIANT: we assume {\em no shadowing}.  (ToDo: How can we ASSERT
-this? WDP 94/06) This allows us to neglect keeping everything paired
-with its static environment.
-
-The environment contains bindings for all
-       {\em in-scope,}
-       {\em locally-defined}
-things.
-
-For such things, any unfolding is found in the environment, not in the
-Id.  Unfoldings in the Id itself are used only for imported things
-(otherwise we get trouble because we have to simplify the unfoldings
-inside the Ids, etc.).
-
 \begin{code}
 data SimplEnv
-  = SimplEnv
-       SwitchChecker
-       CostCentre              -- The enclosing cost-centre (when profiling)
-       InTypeEnv               -- Maps old type variables to new clones
-       InIdEnv                 -- Maps locally-bound Ids to new clones
-       OutIdEnv                -- Info about the values of OutIds
-       ConAppMap               -- Maps constructor applications back to OutIds
-
+  = SimplEnv {
+       seMode      :: SimplifierMode,
+       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 substitution
+       seTvSubst   :: TvSubstEnv,      -- InTyVar |--> OutType
+       seIdSubst   :: SimplIdSubst     -- InId    |--> OutExpr
+    }
+
+type SimplIdSubst = IdEnv SimplSR      -- IdId |--> OutExpr
+
+data SimplSR
+  = DoneEx OutExpr             -- Completed term
+  | DoneId OutId OccInfo       -- Completed term variable, with occurrence info
+  | ContEx TvSubstEnv          -- A suspended substitution
+          SimplIdSubst
+          InExpr        
+\end{code}
 
-nullSimplEnv :: SwitchChecker -> SimplEnv
 
-nullSimplEnv sw_chkr
-  = SimplEnv sw_chkr noCostCentre nullTyVarEnv nullIdEnv nullIdEnv nullConApps
+seInScope: 
+       The in-scope part of Subst includes *all* in-scope TyVars and Ids
+       The elements of the set may have better IdInfo than the
+       occurrences of in-scope Ids, and (more important) they will
+       have a correctly-substituted type.  So we use a lookup in this
+       set to replace occurrences
 
-combineSimplEnv :: SimplEnv -> SimplEnv -> SimplEnv
-combineSimplEnv env@(SimplEnv chkr _       _      _         out_id_env con_apps)
-           new_env@(SimplEnv _    encl_cc ty_env in_id_env _          _       )
-  = SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps
+       The Ids in the InScopeSet are replete with their Rules,
+       and as we gather info about the unfolding of an Id, we replace
+       it in the in-scope set.  
 
-pprSimplEnv (SimplEnv _ _ ty_env in_id_env out_id_env con_apps) = panic "pprSimplEnv"
-\end{code}
+       The in-scope set is actually a mapping OutVar -> OutVar, and
+       in case expressions we sometimes bind 
 
+seIdSubst:
+       The substitution is *apply-once* only, because InIds and OutIds can overlap.
+       For example, we generally omit mappings 
+               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
+               let y = case k of I# x77 -> ... in ...
+       and suppose the body is strict in both x and y.  Then the simplifier
+       will pull the first (case k) to the top; so the second (case k) will
+       cancel out, mapping x77 to, well, x77!  But one is an in-Id and the 
+       other is an out-Id. 
+
+       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.
+
+  Note, though that the substitution isn't necessarily extended
+  if the type changes.  Why not?  Because of the next point:
+
+* We *always, always* finish by looking up in the in-scope set 
+  any variable that doesn't get a DoneEx or DoneVar hit in the substitution.
+  Reason: so that we never finish up with a "old" Id in the result.  
+  An old Id might point to an old unfolding and so on... which gives a space leak.
+
+  [The DoneEx and DoneVar hits map to "new" stuff.]
+
+* It follows that substExpr must not do a no-op if the substitution is empty.
+  substType is free to do so, however.
+
+* When we come to a let-binding (say) we generate new IdInfo, including an
+  unfolding, attach it to the binder, and add this newly adorned binder to
+  the in-scope set.  So all subsequent occurrences of the binder will get mapped
+  to the full-adorned binder, which is also the one put in the binding site.
+
+* The in-scope "set" usually maps x->x; we use it simply for its domain.
+  But sometimes we have two in-scope Ids that are synomyms, and should
+  map to the same target:  x->x, y->x.  Notably:
+       case y of x { ... }
+  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
 
-%************************************************************************
-%*                                                                     *
-\subsubsection{Command-line switches}
-%*                                                                     *
-%************************************************************************
 
 \begin{code}
+mkSimplEnv :: SimplifierMode -> SwitchChecker -> RuleBase -> SimplEnv
+mkSimplEnv mode switches rules
+  = SimplEnv { seChkr = switches, seCC = subsumedCCS, 
+              seMode = mode, seInScope = emptyInScopeSet, 
+              seExtRules = rules,
+              seTvSubst = emptyVarEnv, seIdSubst = emptyVarEnv }
+       -- The top level "enclosing CC" is "SUBSUMED".
+
+---------------------
 getSwitchChecker :: SimplEnv -> SwitchChecker
-getSwitchChecker (SimplEnv chkr _ _ _ _ _) = chkr
-
-switchIsSet :: SimplEnv -> SimplifierSwitch -> Bool
-switchIsSet (SimplEnv chkr _ _ _ _ _) switch
-  = switchIsOn chkr switch
+getSwitchChecker env = seChkr env
 
-getSimplIntSwitch :: SwitchChecker -> (Int-> SimplifierSwitch) -> Int
-getSimplIntSwitch chkr switch
-  = expectJust "getSimplIntSwitch" (intSwitchSet chkr switch)
+---------------------
+getMode :: SimplEnv -> SimplifierMode
+getMode env = seMode env
 
-       -- Crude, but simple
-setCaseScrutinee :: SimplEnv -> SimplEnv
-setCaseScrutinee (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
-  = SimplEnv chkr' encl_cc ty_env in_id_env out_id_env con_apps
-  where
-    chkr' SimplCaseScrutinee = SwBool True
-    chkr' other                     = chkr other
-\end{code}
+setMode :: SimplifierMode -> SimplEnv -> SimplEnv
+setMode mode env = env { seMode = mode }
 
-@switchOffInlining@ is used to prepare the environment for simplifying
-the RHS of an Id that's marked with an INLINE pragma.  It is going to
-be inlined wherever they are used, and then all the inlining will take
-effect.  Meanwhile, there isn't much point in doing anything to the
-as-yet-un-INLINEd rhs.  Furthremore, it's very important to switch off
-inlining!  because
-       (a) not doing so will inline a worker straight back into its wrapper!
-
-and    (b) Consider the following example 
-               let f = \pq -> BIG
-               in
-               let g = \y -> f y y
-                   {-# INLINE g #-}
-               in ...g...g...g...g...g...
-
-       Now, if that's the ONLY occurrence of f, it will be inlined inside g,
-       and thence copied multiple times when g is inlined.
-
-       Andy disagrees! Example:
-               all xs = foldr (&&) True xs
-               any p = all . map p  {-# INLINE any #-}
-       
-       Problem: any won't get deforested, and so if it's exported and
-       the importer doesn't use the inlining, (eg passes it as an arg)
-       then we won't get deforestation at all.
-       We havn't solved this problem yet!
+---------------------
+getEnclosingCC :: SimplEnv -> CostCentreStack
+getEnclosingCC env = seCC env
 
-We prepare the envt by simply discarding the out_id_env, which has
-all the unfolding info. At one point we did it by modifying the chkr so
-that it said "EssentialUnfoldingsOnly", but that prevented legitmate, and important,
-simplifications happening in the body of the RHS.
+setEnclosingCC :: SimplEnv -> CostCentreStack -> SimplEnv
+setEnclosingCC env cc = env {seCC = cc}
 
-\begin{code}
-switchOffInlining :: SimplEnv -> SimplEnv
-switchOffInlining (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
-  = SimplEnv chkr encl_cc ty_env in_id_env nullIdEnv nullConApps
-\end{code}
+---------------------
+extendIdSubst :: SimplEnv -> Id -> SimplSR -> SimplEnv
+extendIdSubst env@(SimplEnv {seIdSubst = subst}) var res
+  = env {seIdSubst = extendVarEnv subst var res}
 
-%************************************************************************
-%*                                                                     *
-\subsubsection{The ``enclosing cost-centre''}
-%*                                                                     *
-%************************************************************************
+extendTvSubst :: SimplEnv -> TyVar -> Type -> SimplEnv
+extendTvSubst env@(SimplEnv {seTvSubst = subst}) var res
+  = env {seTvSubst = extendVarEnv subst var res}
 
-\begin{code}
-setEnclosingCC :: SimplEnv -> CostCentre -> SimplEnv
+---------------------
+getInScope :: SimplEnv -> InScopeSet
+getInScope env = seInScope env
 
-setEnclosingCC (SimplEnv chkr _ ty_env in_id_env out_id_env con_apps) encl_cc
-  = SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps
+setInScopeSet :: SimplEnv -> InScopeSet -> SimplEnv
+setInScopeSet env in_scope = env {seInScope = in_scope}
 
-getEnclosingCC :: SimplEnv -> CostCentre
-getEnclosingCC (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) = encl_cc
-\end{code}
+setInScope :: SimplEnv -> SimplEnv -> SimplEnv
+setInScope env env_with_in_scope = setInScopeSet env (getInScope env_with_in_scope)
 
-%************************************************************************
-%*                                                                     *
-\subsubsection{The @TypeEnv@ part}
-%*                                                                     *
-%************************************************************************
+addNewInScopeIds :: SimplEnv -> [CoreBndr] -> SimplEnv
+       -- The new Ids are guaranteed to be freshly allocated
+addNewInScopeIds env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) vs
+  = env { seInScope = in_scope `extendInScopeSetList` vs,
+         seIdSubst = id_subst `delVarEnvList` vs }
+       -- Why delete?  Consider 
+       --      let x = a*b in (x, \x -> x+3)
+       -- We add [x |-> a*b] to the substitution, but we must
+       -- *delete* it from the substitution when going inside
+       -- the (\x -> ...)!
 
-\begin{code}
-type TypeEnv = TyVarEnv Type
-type InTypeEnv = TypeEnv       -- Maps InTyVars to OutTypes
+modifyInScope :: SimplEnv -> CoreBndr -> CoreBndr -> SimplEnv
+modifyInScope env@(SimplEnv {seInScope = in_scope}) v v'
+  = env {seInScope = modifyInScopeSet in_scope v v'}
 
-extendTyEnv :: SimplEnv -> TyVar -> Type -> SimplEnv
-extendTyEnv (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) tyvar ty
-  = SimplEnv chkr encl_cc new_ty_env in_id_env out_id_env con_apps
-  where
-    new_ty_env = addOneToTyVarEnv ty_env tyvar ty
+---------------------
+zapSubstEnv :: SimplEnv -> SimplEnv
+zapSubstEnv env = env {seTvSubst = emptyVarEnv, seIdSubst = emptyVarEnv}
 
-extendTyEnvList :: SimplEnv -> [(TyVar,Type)] -> SimplEnv
-extendTyEnvList (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) pairs
-  = SimplEnv chkr encl_cc new_ty_env in_id_env out_id_env con_apps
-  where
-    new_ty_env = growTyVarEnvList ty_env pairs
+setSubstEnv :: SimplEnv -> TvSubstEnv -> SimplIdSubst -> SimplEnv
+setSubstEnv env tvs ids = env { seTvSubst = tvs, seIdSubst = ids }
 
-simplTy     (SimplEnv _ _ ty_env _ _ _) ty = returnEager (applyTypeEnvToTy ty_env ty)
-simplTyInId (SimplEnv _ _ ty_env _ _ _) id = returnEager (applyTypeEnvToId ty_env id)
-\end{code}
+mkContEx :: SimplEnv -> InExpr -> SimplSR
+mkContEx (SimplEnv { seTvSubst = tvs, seIdSubst = ids }) e = ContEx tvs ids e
 
-%************************************************************************
-%*                                                                     *
-\subsubsection{The ``Id env'' part}
-%*                                                                     *
-%************************************************************************
+isEmptySimplSubst :: SimplEnv -> Bool
+isEmptySimplSubst (SimplEnv { seTvSubst = tvs, seIdSubst = ids })
+  = isEmptyVarEnv tvs && isEmptyVarEnv ids
 
-\begin{code}
-type InIdEnv = IdEnv OutArg    -- Maps InIds to their value
-                               -- Usually this is just the cloned Id, but if
-                               -- if the orig defn is a let-binding, and
-                               -- the RHS of the let simplifies to an atom,
-                               -- we just bind the variable to that atom, and
-                               -- elide the let.
+---------------------
+getRules :: SimplEnv -> RuleBase
+getRules = seExtRules
 \end{code}
 
-\begin{code}
-lookupId :: SimplEnv -> Id -> Eager ans OutArg
+               GADT stuff
 
-lookupId (SimplEnv _ _ _ in_id_env _ _) id
-  = case (lookupIdEnv in_id_env id) of
-      Just atom -> returnEager atom
-      Nothing   -> returnEager (VarArg id)
-\end{code}
+Given an idempotent substitution, generated by the unifier, use it to 
+refine the environment
 
 \begin{code}
-extendIdEnvWithAtom
-       :: SimplEnv
-       -> InBinder
-        -> OutArg{-Val args only, please-}
-       -> SimplEnv
-
-extendIdEnvWithAtom (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
-                   (in_id,occ_info) atom
-  = case atom of
-     LitArg _      -> SimplEnv chkr encl_cc ty_env new_in_id_env out_id_env con_apps
-     VarArg out_id -> SimplEnv chkr encl_cc ty_env new_in_id_env 
-                              (modifyOccInfo out_id_env (uniqueOf out_id, occ_info)) con_apps
---SimplEnv chkr encl_cc ty_env new_in_id_env new_out_id_env con_apps
+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' }
   where
-    new_in_id_env  = addOneToIdEnv in_id_env in_id atom
-{-
-    new_out_id_env = case atom of
-                       LitArg _      -> out_id_env
-                       VarArg out_id -> modifyOccInfo out_id_env (uniqueOf out_id, occ_info)
--}
-
-extendIdEnvWithAtoms :: SimplEnv -> [(InBinder, OutArg)] -> SimplEnv
-extendIdEnvWithAtoms = foldr (\ (bndr,val) env -> extendIdEnvWithAtom env bndr val)
-
-
-extendIdEnvWithClone :: SimplEnv -> InBinder -> OutId -> SimplEnv
-
-extendIdEnvWithClone (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
-                    (in_id,_) out_id
-  = SimplEnv chkr encl_cc ty_env new_in_id_env out_id_env con_apps
-  where
-    new_in_id_env = addOneToIdEnv in_id_env in_id (VarArg out_id)
-
-extendIdEnvWithClones :: SimplEnv -> [InBinder] -> [OutId] -> SimplEnv
-extendIdEnvWithClones (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
-                     in_binders out_ids
-  = SimplEnv chkr encl_cc ty_env new_in_id_env out_id_env con_apps
-  where
-    new_in_id_env = growIdEnvList in_id_env bindings
-    bindings      = zipEqual "extendIdEnvWithClones"
-                            [id | (id,_) <- in_binders]
-                            (map VarArg out_ids)
+    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
 \end{code}
 
 %************************************************************************
 %*                                                                     *
-\subsubsection{The @OutIdEnv@}
+               Substitution of Vars
 %*                                                                     *
 %************************************************************************
 
 
-The domain of @OutIdInfo@ is some, but not necessarily all, in-scope @OutId@s;
-both locally-bound ones, and perhaps some imported ones too.
-
-\begin{code}
-type OutIdEnv = IdEnv (OutId, BinderInfo, RhsInfo)
-
-\end{code}
-
-The "Id" part is just so that we can recover the domain of the mapping, which
-IdEnvs don't allow directly.
-
-The @BinderInfo@ tells about the occurrences of the @OutId@.
-Anything that isn't in here should be assumed to occur many times.
-We keep this info so we can modify it when something changes.
-
-The @RhsInfo@ part tells about the value to which the @OutId@ is bound.
-
 \begin{code}
-data RhsInfo = NoRhsInfo
-            | OtherLit [Literal]               -- It ain't one of these
-            | OtherCon [Id]                    -- It ain't one of these
-
-            | InUnfolding SimplEnv             -- Un-simplified unfolding
-                          SimpleUnfolding      -- (need to snag envts therefore)
-
-            | OutUnfolding CostCentre
-                           SimpleUnfolding     -- Already-simplified unfolding
-
-lookupOutIdEnv :: SimplEnv -> OutId -> Maybe (OutId,BinderInfo,RhsInfo)
-lookupOutIdEnv (SimplEnv _ _ _ _ out_id_env _) id = lookupIdEnv out_id_env id
-
-lookupRhsInfo :: SimplEnv -> OutId -> RhsInfo
-lookupRhsInfo env id
-  = case lookupOutIdEnv env id of
-       Just (_,_,info) -> info
-       Nothing         -> NoRhsInfo
-
-modifyOutEnvItem :: (OutId, BinderInfo, RhsInfo)
-                -> (OutId, BinderInfo, RhsInfo) 
-                -> (OutId, BinderInfo, RhsInfo)
-modifyOutEnvItem (id, occ, info1) (_, _, info2)
-  = case (info1, info2) of
-               (OtherLit ls1, OtherLit ls2) -> (id,occ, OtherLit (ls1++ls2))
-               (OtherCon cs1, OtherCon cs2) -> (id,occ, OtherCon (cs1++cs2))
-               (_,            NoRhsInfo)    -> (id,occ, info1)
-               other                        -> (id,occ, info2)
+substId :: SimplEnv -> Id -> SimplSR
+substId (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v 
+  | not (isLocalId v) 
+  = DoneId v NoOccInfo
+  | 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
+  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
+       -- 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!
 \end{code}
 
 
-\begin{code}
-isEvaluated :: RhsInfo -> Bool
-isEvaluated (OtherLit _) = True
-isEvaluated (OtherCon _) = True
-isEvaluated (InUnfolding _  (SimpleUnfolding ValueForm _ expr)) = True
-isEvaluated (OutUnfolding _ (SimpleUnfolding ValueForm _ expr)) = True
-isEvaluated other = False
-\end{code}
+%************************************************************************
+%*                                                                     *
+\section{Substituting an Id binder}
+%*                                                                     *
+%************************************************************************
 
 
+These functions are in the monad only so that they can be made strict via seq.
 
 \begin{code}
-mkSimplUnfoldingGuidance chkr out_id rhs
-  = calcUnfoldingGuidance (getInlinePragma out_id) opt_UnfoldingCreationThreshold rhs
-
-extendEnvGivenRhsInfo :: SimplEnv -> OutId -> BinderInfo -> RhsInfo -> SimplEnv
-extendEnvGivenRhsInfo env@(SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
-                     out_id occ_info rhs_info
-  = SimplEnv chkr encl_cc ty_env in_id_env new_out_id_env con_apps
+simplBinders, simplLamBndrs
+       :: SimplEnv -> [InBinder] -> SimplM (SimplEnv, [OutBinder])
+simplBinders  env bndrs = mapAccumLSmpl simplBinder  env bndrs
+simplLamBndrs env bndrs = mapAccumLSmpl simplLamBndr env bndrs
+
+-------------
+simplBinder :: SimplEnv -> InBinder -> SimplM (SimplEnv, OutBinder)
+-- Used for lambda and case-bound variables
+-- Clone Id if necessary, substitute type
+-- Return with IdInfo already substituted, but (fragile) occurrence info zapped
+-- The substitution is extended only if the variable is cloned, because
+-- we *don't* need to use it to track occurrence info.
+simplBinder env bndr
+  | isTyVar bndr  = do { let (env', tv) = substTyVarBndr env bndr
+                       ; seqTyVar tv `seq` return (env', tv) }
+  | otherwise     = do { let (env', id) = substIdBndr env bndr
+                       ; seqId id `seq` return (env', id) }
+
+-------------
+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
+-- 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)
+  where
+    old_unf = idUnfolding bndr
+    (env', id1) = substIdBndr env bndr
+    id2 = id1 `setIdUnfolding` substUnfolding env old_unf
+
+--------------
+substIdBndr :: SimplEnv -> Id  -- Substitition and Id to transform
+           -> (SimplEnv, Id)   -- Transformed pair
+
+-- Returns with:
+--     * Unique changed if necessary
+--     * Type substituted
+--     * Unfolding zapped
+--     * Rules, worker, lbvar info all substituted 
+--     * Fragile occurrence info zapped
+--     * The in-scope set extended with the returned Id
+--     * The substitution extended with a DoneId if unique changed
+--       In this case, the var in the DoneId is the same as the
+--       var returned
+
+substIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst})
+           old_id
+  = (env { seInScope = in_scope `extendInScopeSet` new_id,
+          seIdSubst = new_subst }, new_id)
   where
-    new_out_id_env = addToUFM_C modifyOutEnvItem out_id_env out_id 
-                               (out_id, occ_info, rhs_info)
+       -- id1 is cloned if necessary
+    id1 = uniqAway in_scope old_id
+
+       -- id2 has its type zapped
+    id2 = substIdType env id1
+
+       -- new_id has the final IdInfo
+    subst  = mkCoreSubst env
+    new_id = maybeModifyIdInfo (substIdInfo subst) id2
+
+       -- Extend the substitution if the unique has changed
+       -- See the notes with substTyVarBndr for the delSubstEnv
+    new_subst | new_id /= old_id
+             = extendVarEnv id_subst old_id (DoneId new_id (idOccInfo old_id))
+             | otherwise 
+             = delVarEnv id_subst old_id
 \end{code}
 
 
 \begin{code}
-modifyOccInfo out_id_env (uniq, new_occ)
-  = modifyIdEnv_Directly modify_fn out_id_env uniq
-  where
-    modify_fn (id,occ,rhs) = (id, orBinderInfo occ new_occ, rhs)
+seqTyVar :: TyVar -> ()
+seqTyVar b = b `seq` ()
 
-markDangerousOccs (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) atoms
-  = SimplEnv chkr encl_cc ty_env in_id_env new_out_id_env con_apps
-  where
-    new_out_id_env = foldl (modifyIdEnv modify_fn) out_id_env [v | VarArg v <- atoms]
-    modify_fn (id,occ,rhs) = (id, noBinderInfo, rhs)
-\end{code}
+seqId :: Id -> ()
+seqId id = seqType (idType id) `seq`
+          idInfo id            `seq`
+          ()
 
+seqIds :: [Id] -> ()
+seqIds []       = ()
+seqIds (id:ids) = seqId id `seq` seqIds ids
+\end{code}
 
 
 %************************************************************************
 %*                                                                     *
-\subsubsection{The @ConAppMap@ type}
+               Let bindings
 %*                                                                     *
 %************************************************************************
 
-The @ConAppMap@ maps applications of constructors (to value atoms)
-back to an association list that says "if the constructor was applied
-to one of these lists-of-Types, then this OutId is your man (in a
-non-gender-specific sense)".  I.e., this is a reversed mapping for
-(part of) the main OutIdEnv
-
-\begin{code}
-type ConAppMap = FiniteMap UnfoldConApp [([Type], OutId)]
-
-data UnfoldConApp
-  = UCA                OutId                   -- data constructor
-               [OutArg]                -- *value* arguments; see use below
-\end{code}
+Simplifying let binders
+~~~~~~~~~~~~~~~~~~~~~~~
+Rename the binders if necessary, 
 
 \begin{code}
-nullConApps = emptyFM
-
-extendConApps con_apps id (Con con args)
-  = addToFM_C (\old new -> new++old) con_apps (UCA con val_args) [(ty_args,id)]
+simplNonRecBndr :: SimplEnv -> InBinder -> SimplM (SimplEnv, OutBinder)
+simplNonRecBndr env id
+  = do { let (env1, id1) = substLetIdBndr env id
+       ; seqId id1 `seq` return (env1, id1) }
+
+---------------
+simplRecBndrs :: SimplEnv -> [InBinder] -> SimplM (SimplEnv, [OutBinder])
+simplRecBndrs env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) ids
+  = do { let (env1, ids1) = mapAccumL substLetIdBndr env ids
+       ; seqIds ids1 `seq` return (env1, ids1) }
+
+---------------
+substLetIdBndr :: SimplEnv -> InBinder         -- Env and binder to transform
+              -> (SimplEnv, OutBinder)
+-- C.f. CoreSubst.substIdBndr
+-- Clone Id if necessary, substitute its type
+-- Return an Id with completely zapped IdInfo
+--     [addLetIdInfo, below, will restore its IdInfo]
+-- Augment the subtitution 
+--     if the unique changed, *or* 
+--     if there's interesting occurrence info
+
+substLetIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) old_id
+  = (env { seInScope = in_scope `extendInScopeSet` new_id, 
+          seIdSubst = new_subst }, new_id)
   where
-    val_args = filter isValArg args            -- Literals and Ids
-    ty_args  = [ty | TyArg ty <- args]         -- Just types
-
-extendConApps con_apps id other_rhs = con_apps
+    id1           = uniqAway in_scope old_id
+    id2    = substIdType env id1
+    new_id = setIdInfo id2 vanillaIdInfo
+
+       -- 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)
+             | otherwise 
+             = delVarEnv id_subst old_id
 \end{code}
 
+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
+       rules
+       worker info
+etc.  To do this we must apply the current substitution, 
+which incorporates earlier substitutions in this very letrec group.
+
+NB 1. We do this *before* processing the RHS of the binder, so that
+its substituted rules are visible in its own RHS.
+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.
+
+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
+       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.
+
+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 4: does no harm for non-recursive bindings
+
+NB 5: we can't do the addLetIdInfo part before *all* the RHSs because
+       rec { f = g
+             h = ...
+               RULE h Int = f
+       }
+Here, we'll do postInlineUnconditionally on f, and we must "see" that 
+when substituting in h's RULE.  
+
 \begin{code}
-lookForConstructor (SimplEnv _ _ _ _ _ con_apps) con args
-  = case lookupFM con_apps (UCA con val_args) of
-       Nothing     -> Nothing
-
-       Just assocs -> case [id | (tys, id) <- assocs, 
-                                 and (zipWith eqTy tys ty_args)]
-                      of
-                         []     -> Nothing
-                         (id:_) -> Just id
+addLetIdInfo :: SimplEnv -> InBinder -> OutBinder -> (SimplEnv, OutBinder)
+addLetIdInfo env in_id out_id
+  = (modifyInScope env out_id out_id, final_id)
+  where
+    final_id = out_id `setIdInfo` new_info
+    subst = mkCoreSubst env
+    old_info = idInfo in_id
+    new_info = case substIdInfo subst old_info of
+                 Nothing       -> old_info
+                 Just new_info -> new_info
+
+substIdInfo :: CoreSubst.Subst -> IdInfo -> Maybe IdInfo
+-- Substitute the 
+--     rules
+--     worker info
+-- Zap the unfolding 
+-- Keep only 'robust' OccInfo
+-- Zap Arity
+-- 
+-- Seq'ing on the returned IdInfo is enough to cause all the 
+-- substitutions to happen completely
+
+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
-    val_args = filter isValArg args            -- Literals and Ids
-    ty_args  = [ty | TyArg ty <- args]         -- Just types
+    nothing_to_do = keep_occ && keep_arity &&
+                   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
+    old_occ   = occInfo info
+    old_rules = specInfo info
+    old_wrkr  = workerInfo info
+
+------------------
+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)
+               -- 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
+  where
+    old_ty = idType id
 
+------------------
+substUnfolding env NoUnfolding                = NoUnfolding
+substUnfolding env (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
 \end{code}
 
-NB: In @lookForConstructor@ we used (before Apr 94) to have a special case
-for nullary constructors, but now we only do constructor re-use in
-let-bindings the special case isn't necessary any more.
-
-\begin{verbatim}       
-  =    -- Don't re-use nullary constructors; it's a waste.  Consider
-       -- let
-       --        a = leInt#! p q
-       -- in
-       -- case a of
-       --    True  -> ...
-       --    False -> False
-       --
-       -- Here the False in the second case will get replace by "a", hardly
-       -- a good idea
-    Nothing
-\end{verbatim}
 
-
-The main thing about @UnfoldConApp@ is that it has @Ord@ defined on
-it, so we can use it for a @FiniteMap@ key.
+%************************************************************************
+%*                                                                     *
+               Impedence matching to type substitution
+%*                                                                     *
+%************************************************************************
 
 \begin{code}
-instance Eq  UnfoldConApp where
-    a == b = case (a `cmp` b) of { EQ_ -> True;   _ -> False }
-    a /= b = case (a `cmp` b) of { EQ_ -> False;  _ -> True  }
-
-instance Ord UnfoldConApp where
-    a <= b = case (a `cmp` b) of { LT_ -> True;  EQ_ -> True;  GT__ -> False }
-    a <  b = case (a `cmp` b) of { LT_ -> True;  EQ_ -> False; GT__ -> False }
-    a >= b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True;  GT__ -> True  }
-    a >  b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True  }
-    _tagCmp a b = case (a `cmp` b) of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
-
-instance Ord3 UnfoldConApp where
-    cmp = cmp_app
-
-cmp_app (UCA c1 as1) (UCA c2 as2)
-  = cmp c1 c2 `thenCmp` cmpList cmp_arg as1 as2
+substTy :: SimplEnv -> Type -> Type 
+substTy (SimplEnv { seInScope = in_scope, seTvSubst = tv_env }) ty
+  = Type.substTy (TvSubst in_scope tv_env) ty
+
+substTyVarBndr :: SimplEnv -> TyVar -> (SimplEnv, TyVar)
+substTyVarBndr env@(SimplEnv { seInScope = in_scope, seTvSubst = tv_env }) tv
+  = case Type.substTyVarBndr (TvSubst in_scope tv_env) tv of
+       (TvSubst in_scope' tv_env', tv') 
+          -> (env { seInScope = in_scope', seTvSubst = tv_env'}, tv')
+
+-- When substituting in rules etc we can get CoreSubst to do the work
+-- But CoreSubst uses a simpler form of IdSubstEnv, so we must impedence-match
+-- here.  I think the this will not usually result in a lot of work;
+-- the substitutions are typically small, and laziness will avoid work in many cases.
+
+mkCoreSubst  :: SimplEnv -> CoreSubst.Subst
+mkCoreSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seIdSubst = id_env })
+  = mk_subst tv_env id_env
   where
-    -- ToDo: make an "instance Ord3 CoreArg"???
-
-    cmp_arg (VarArg   x) (VarArg   y) = x `cmp` y
-    cmp_arg (LitArg   x) (LitArg   y) = x `cmp` y
-    cmp_arg (TyArg    x) (TyArg    y) = panic# "SimplEnv.cmp_app:TyArgs"
-    cmp_arg (UsageArg x) (UsageArg y) = panic# "SimplEnv.cmp_app:UsageArgs"
-    cmp_arg x y
-      | tag x _LT_ tag y = LT_
-      | otherwise       = GT_
-      where
-       tag (VarArg   _) = ILIT(1)
-       tag (LitArg   _) = ILIT(2)
-       tag (TyArg    _) = panic# "SimplEnv.cmp_app:TyArg"
-       tag (UsageArg _) = panic# "SimplEnv.cmp_app:UsageArg"
-\end{code}
-
-
+    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 (ContEx tv id e) = CoreSubst.substExpr (mk_subst tv id) e
 
+substExpr :: SimplEnv -> CoreExpr -> CoreExpr
+substExpr env expr
+  | isEmptySimplSubst env = expr
+  | otherwise            = CoreSubst.substExpr (mkCoreSubst env) expr
+\end{code}
 
-============================  OLD ================================
-       This version was used when we use the *simplified* RHS of a 
-       let as the thing's unfolding.  The has the nasty property described
-       in the following comments.  Much worse, it can fail to terminate
-       on recursive things.  Consider
-
-               letrec f = \x -> let z = f x' in ...
 
-               in
-               let n = f y
-               in
-               case n of { ... }
+%************************************************************************
+%*                                                                     *
+\subsection{Floats}
+%*                                                                     *
+%************************************************************************
 
-       If we bind n to its *simplified* RHS, we then *re-simplify* it when
-       we inline n.  Then we may well inline f; and then the same thing
-       happens with z!
+\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
 
-@extendUnfoldEnvGivenRhs@ records in the UnfoldEnv info about the RHS
-of a new binding.  There is a horrid case we have to take care about,
-due to Andr\'e Santos:
-@
-    type Array_type b   = Array Int b;
-    type Descr_type     = (Int,Int);
+allLifted :: Floats -> Bool
+allLifted (Floats _ _ is_lifted) = is_lifted
 
-    tabulate      :: (Int -> x) -> Descr_type -> Array_type x;
-    tabulate      f (l,u)             = listArray (l,u) [f i | i <- [l..u]];
+wrapFloats :: Floats -> OutExpr -> OutExpr
+wrapFloats (Floats bs _ _) body = foldrOL Let body bs
 
-    f_iaamain a_xs=
-       let {
-           f_aareorder::(Array_type Int) -> (Array_type t1) -> Array_type t1;
-           f_aareorder a_index a_ar=
-               let {
-                   f_aareorder' a_i= a_ar ! (a_index ! a_i)
-                } in  tabulate f_aareorder' (bounds a_ar);
-           r_index=tabulate ((+) 1) (1,1);
-           arr    = listArray (1,1) a_xs;
-           arg    = f_aareorder r_index arr
-        } in  elems arg
-@
-Now, when the RHS of arg gets simplified, we inline f_aareorder to get
-@
-       arg  = let f_aareorder' a_i = arr ! (r_index ! a_i)
-              in tabulate f_aareorder' (bounds arr)
-@
-Note that r_index is not inlined, because it was bound to a_index which
-occurs inside a lambda.
+isEmptyFloats :: Floats -> Bool
+isEmptyFloats (Floats bs _ _) = isNilOL bs 
 
-Alas, if elems is inlined, so that (elems arg) becomes (case arg of ...),
-then arg is inlined. IF WE USE THE NEW VERSION OF arg, and re-occurrence
-analyse it, we won't spot the inside-lambda property of r_index, so r_index
-will get inlined inside the lambda.  AARGH.
+floatBinds :: Floats -> [OutBind]
+floatBinds (Floats bs _ _) = fromOL bs
 
-Solution: when we occurrence-analyse the new RHS we have to go back
-and modify the info recorded in the UnfoldEnv for the free vars
-of the RHS.  In the example we'd go back and record that r_index is now used
-inside a lambda.
+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}
-extendEnvGivenNewRhs :: SimplEnv -> OutId -> OutExpr -> SimplEnv
-extendEnvGivenNewRhs env out_id rhs
-  = extendEnvGivenBinding env noBinderInfo out_id rhs
-
-extendEnvGivenBinding :: SimplEnv -> BinderInfo -> OutId -> OutExpr -> SimplEnv
-extendEnvGivenBinding env@(SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
-                     occ_info out_id rhs
-  = SimplEnv chkr encl_cc ty_env in_id_env new_out_id_env new_con_apps 
-  where
-    new_out_id_env = case guidance of
-                       UnfoldNever -> out_id_env               -- No new stuff to put in
-                       other       -> out_id_env_with_unfolding
-
-    new_con_apps = _scc_ "eegnr.conapps" 
-                  extendConApps con_apps out_id rhs
-
-       -- Modify the occ info for rhs's interesting free variables.
-    out_id_env_with_unfolding = _scc_ "eegnr.modify_occ" 
-                               foldl modifyOccInfo env1 full_fv_occ_info
-               -- NB: full_fv_occ_info *combines* the occurrence of the current binder
-               -- with the occurrences of its RHS's free variables.  That's to take
-               -- account of:
-               --              let a = \x -> BIG in
-               --              let b = \f -> f a
-               --              in ...b...b...b...
-               -- Here "a" occurs exactly once. "b" simplifies to a small value.
-               -- So "b" will be inlined at each call site, and there's a good chance
-               -- that "a" will too.  So we'd better modify "a"s occurrence info to
-               -- record the fact that it can now occur many times by virtue that "b" can.
-
-    full_fv_occ_info         = _scc_ "eegnr.full_fv" 
-                               [ (uniq, fv_occ `andBinderInfo` occ_info) 
-                               | (uniq, fv_occ) <- ufmToList fv_occ_info
-                               ]
-
-       -- Add an unfolding and rhs_info for the new Id.
-       -- If the out_id is already in the OutIdEnv (which can happen if
-       -- the call to extendEnvGivenBinding is from extendEnvGivenNewRhs)
-       -- then just replace the unfolding, leaving occurrence info alone.
-    env1                     = _scc_ "eegnr.modify_out" 
-                               addToUFM_C modifyOutEnvItem out_id_env out_id 
-                                          (out_id, occ_info, rhs_info)
-
-       -- Occurrence-analyse the RHS
-       -- The "interesting" free variables we want occurrence info for are those
-       -- in the OutIdEnv that have only a single occurrence right now.
-    (fv_occ_info, template) = _scc_ "eegnr.occ-anal" 
-                             occurAnalyseExpr is_interesting rhs
-
-    is_interesting v        = _scc_ "eegnr.mkidset" 
-                             case lookupIdEnv out_id_env v of
-                               Just (_, OneOcc _ _ _ _ _, _) -> True
-                               other                         -> False
-
-       -- Compute unfolding details
-    rhs_info     = OutUnfolding unf_cc (SimpleUnfolding form_summary guidance template)
-    form_summary = _scc_ "eegnr.form_sum" 
-                  mkFormSummary rhs
-    guidance     = _scc_ "eegnr.guidance" 
-                  mkSimplUnfoldingGuidance chkr out_id rhs
-
-       -- Compute cost centre for thing
-    unf_cc  | noCostCentreAttached expr_cc = encl_cc
-           | otherwise                    = expr_cc
-           where
-             expr_cc =  coreExprCc rhs
+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}
 
 
-
-
-========================== OLD [removed SLPJ March 97] ====================
-
-I removed the attempt to inline recursive bindings when I discovered
-a program that made the simplifier loop  (nofib/spectral/hartel/typecheck/Main.hs)
-
-The nasty case is this:
-
-               letrec f = \x -> let z = f x' in ...
-
-               in
-               let n = f y
-               in
-               case n of { ... }
-
-If we bind n to its *simplified* RHS, we then *re-simplify* it when we
-inline n.  Then we may well inline f; and then the same thing happens
-with z!
-
-Recursive bindings
-~~~~~~~~~~~~~~~~~~
-We need to be pretty careful when extending 
-the environment with RHS info in recursive groups.
-
-Here's a nasty example:
-
-       letrec  r = f x
-               t = r
-               x = ...t...
-       in
-       ...t...
-
-Here, r occurs exactly once, so we may reasonably inline r in t's RHS.
-But the pre-simplified t's rhs is an atom, r, so we may also decide to
-inline t everywhere.  But if we do *both* these reasonable things we get
-
-       letrec  r = f x
-               t = f x
-               x = ...r...
-       in
-       ...t...
-
-Bad news!  (f x) is duplicated!  (The t in the body doesn't get
-inlined because by the time the recursive group is done we see that
-t's RHS isn't an atom.)
-
-Our solution is this: 
-       (a) we inline un-simplified RHSs, and then simplify
-           them in a clone-only environment.  
-       (b) we inline only variables and values
-This means that
-
-
-       r = f x         ==>  r = f x
-       t = r           ==>  t = r
-       x = ...t...     ==>  x = ...r...
-     in                           in
-       t                    r
-
-Now t is dead, and we're home.
-
-Most silly x=y  bindings in recursive group will go away.  But not all:
-
-       let y = 1:x
-           x = y
-
-Here, we can't inline x because it's in an argument position. so we'll just replace
-with a clone of y.  Instead we'll probably inline y (a small value) to give
-
-       let y = 1:x
-           x = 1:y
-       
-which is OK if not clever.
-
-
-
-\begin{code}
-{-
-extendEnvForRecBinding env@(SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
-                      (out_id, ((_,occ_info), old_rhs))
-  = case (form_summary, guidance) of
-     (_, UnfoldNever)  -> SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps -- No new stuff to put in
-     (ValueForm, _)    -> SimplEnv chkr encl_cc ty_env in_id_env out_id_env_with_unfolding con_apps
-     (VarForm, _)      -> SimplEnv chkr encl_cc ty_env in_id_env out_id_env_with_unfolding con_apps
-     other             -> SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps   -- Not a value or variable
-     
--- SimplEnv chkr encl_cc ty_env in_id_env new_out_id_env con_apps
-  where
-{-
-    new_out_id_env = case (form_summary, guidance) of
-                       (_, UnfoldNever)        -> out_id_env           -- No new stuff to put in
-                       (ValueForm, _)          -> out_id_env_with_unfolding
-                       (VarForm, _)            -> out_id_env_with_unfolding
-                       other                   -> out_id_env           -- Not a value or variable
--}
-       -- If there is an unfolding, we add rhs-info for out_id,
-       -- No need to modify occ info because RHS is pre-simplification
-    out_id_env_with_unfolding =        addOneToIdEnv out_id_env out_id 
-                               (out_id, occ_info, rhs_info)
-
-       -- Compute unfolding details
-       -- Note that we use the "old" environment, that just has clones of the rec-bound vars,
-       -- in the InUnfolding.  So if we ever use the InUnfolding we'll just inline once.
-       -- Only if the thing is still small enough next time round will we inline again.
-    rhs_info     = InUnfolding env (SimpleUnfolding form_summary guidance old_rhs)
-    form_summary = mkFormSummary old_rhs
-    guidance     = mkSimplUnfoldingGuidance chkr out_id (unTagBinders old_rhs)
--}
-\end{code}