Reorganisation of the source tree

Most of the other users of the fptools build system have migrated to
Cabal, and with the move to darcs we can now flatten the source tree
without losing history, so here goes.

The main change is that the ghc/ subdir is gone, and most of what it
contained is now at the top level.  The build system now makes no
pretense at being multi-project, it is just the GHC build system.

No doubt this will break many things, and there will be a period of
instability while we fix the dependencies.  A straightforward build
should work, but I haven't yet fixed binary/source distributions.
Changes to the Building Guide will follow, too.

1 files changed, 741 insertions, 0 deletions

diff --git a/compiler/simplCore/SimplEnv.lhs b/compiler/simplCore/SimplEnv.lhs
new file mode 100644
index 0000000000..00f035e513
--- /dev/null
+++ b/compiler/simplCore/SimplEnv.lhs
@@ -0,0 +1,741 @@
+%
+% (c) The AQUA Project, Glasgow University, 1993-1998
+%
+\section[SimplMonad]{The simplifier Monad}
+
+\begin{code}
+module SimplEnv (
+	InId, InBind, InExpr, InAlt, InArg, InType, InBinder,
+	OutId, OutTyVar, OutBind, OutExpr, OutAlt, OutArg, OutType, OutBinder,
+
+	-- The simplifier mode
+	setMode, getMode, 
+
+	-- Switch checker
+	SwitchChecker, SwitchResult(..), getSwitchChecker, getSimplIntSwitch,
+	isAmongSimpl, intSwitchSet, switchIsOn,
+
+	setEnclosingCC, getEnclosingCC,
+
+	-- Environments
+	SimplEnv, mkSimplEnv, extendIdSubst, extendTvSubst, 
+	zapSubstEnv, setSubstEnv, 
+	getInScope, setInScope, setInScopeSet, modifyInScope, addNewInScopeIds,
+	getRules, refineSimplEnv,
+
+	SimplSR(..), mkContEx, substId, 
+
+	simplNonRecBndr, simplRecBndrs, simplLamBndr, simplLamBndrs, 
+ 	simplBinder, simplBinders, addLetIdInfo,
+	substExpr, substTy,
+
+	-- Floats
+	FloatsWith, FloatsWithExpr,
+  	Floats, emptyFloats, isEmptyFloats, unitFloat, addFloats, flattenFloats,
+	allLifted, wrapFloats, floatBinds,
+	addAuxiliaryBind,
+    ) 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 CoreSyn
+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}
+
+%************************************************************************
+%*									*
+\subsection[Simplify-types]{Type declarations}
+%*									*
+%************************************************************************
+
+\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
+\end{code}
+
+%************************************************************************
+%*									*
+\subsubsection{The @SimplEnv@ type}
+%*									*
+%************************************************************************
+
+
+\begin{code}
+data SimplEnv
+  = 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}
+
+
+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
+
+	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.  
+
+	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
+
+
+\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 env = seChkr env
+
+---------------------
+getMode :: SimplEnv -> SimplifierMode
+getMode env = seMode env
+
+setMode :: SimplifierMode -> SimplEnv -> SimplEnv
+setMode mode env = env { seMode = mode }
+
+---------------------
+getEnclosingCC :: SimplEnv -> CostCentreStack
+getEnclosingCC env = seCC env
+
+setEnclosingCC :: SimplEnv -> CostCentreStack -> SimplEnv
+setEnclosingCC env cc = env {seCC = cc}
+
+---------------------
+extendIdSubst :: SimplEnv -> Id -> SimplSR -> SimplEnv
+extendIdSubst env@(SimplEnv {seIdSubst = subst}) var res
+  = env {seIdSubst = extendVarEnv subst var res}
+
+extendTvSubst :: SimplEnv -> TyVar -> Type -> SimplEnv
+extendTvSubst env@(SimplEnv {seTvSubst = subst}) var res
+  = env {seTvSubst = extendVarEnv subst var res}
+
+---------------------
+getInScope :: SimplEnv -> InScopeSet
+getInScope env = seInScope env
+
+setInScopeSet :: SimplEnv -> InScopeSet -> 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)
+
+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 -> ...)!
+
+modifyInScope :: SimplEnv -> CoreBndr -> CoreBndr -> SimplEnv
+modifyInScope env@(SimplEnv {seInScope = in_scope}) v v'
+  = env {seInScope = modifyInScopeSet in_scope v v'}
+
+---------------------
+zapSubstEnv :: SimplEnv -> SimplEnv
+zapSubstEnv env = env {seTvSubst = emptyVarEnv, seIdSubst = emptyVarEnv}
+
+setSubstEnv :: SimplEnv -> TvSubstEnv -> SimplIdSubst -> SimplEnv
+setSubstEnv env tvs ids = env { seTvSubst = tvs, seIdSubst = ids }
+
+mkContEx :: SimplEnv -> InExpr -> SimplSR
+mkContEx (SimplEnv { seTvSubst = tvs, seIdSubst = ids }) e = ContEx tvs ids e
+
+isEmptySimplSubst :: SimplEnv -> Bool
+isEmptySimplSubst (SimplEnv { seTvSubst = tvs, seIdSubst = ids })
+  = isEmptyVarEnv tvs && isEmptyVarEnv ids
+
+---------------------
+getRules :: SimplEnv -> RuleBase
+getRules = seExtRules
+\end{code}
+
+		GADT stuff
+
+Given an idempotent substitution, generated by the unifier, use it to 
+refine the environment
+
+\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' }
+  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
+\end{code}
+
+%************************************************************************
+%*									*
+		Substitution of Vars
+%*									*
+%************************************************************************
+
+
+\begin{code}
+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}
+
+
+%************************************************************************
+%*									*
+\section{Substituting an Id binder}
+%*									*
+%************************************************************************
+
+
+These functions are in the monad only so that they can be made strict via seq.
+
+\begin{code}
+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
+	-- 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}
+seqTyVar :: TyVar -> ()
+seqTyVar b = b `seq` ()
+
+seqId :: Id -> ()
+seqId id = seqType (idType id)	`seq`
+	   idInfo id		`seq`
+	   ()
+
+seqIds :: [Id] -> ()
+seqIds []       = ()
+seqIds (id:ids) = seqId id `seq` seqIds ids
+\end{code}
+
+
+%************************************************************************
+%*									*
+		Let bindings
+%*									*
+%************************************************************************
+
+Simplifying let binders
+~~~~~~~~~~~~~~~~~~~~~~~
+Rename the binders if necessary, 
+
+\begin{code}
+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
+    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}
+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
+    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}
+
+
+%************************************************************************
+%*									*
+		Impedence matching to type substitution
+%*									*
+%************************************************************************
+
+\begin{code}
+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
+    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}
+
+
+%************************************************************************
+%*									*
+\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}
+
+