[project @ 1996-07-15 16:16:46 by partain]

simonpj changes through 960715

55 files changed, 1500 insertions, 2215 deletions

diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs
index 85914c9875..ec613d6e9a 100644
--- a/ghc/compiler/basicTypes/Id.lhs
+++ b/ghc/compiler/basicTypes/Id.lhs
@@ -90,6 +90,10 @@ module Id (
 	pprId,
 	showId,
 
+	-- Specialialisation
+	getIdSpecialisation,
+	addIdSpecialisation,
+
 	-- UNFOLDING, ARITY, UPDATE, AND STRICTNESS STUFF (etc)
 	addIdArity,
 	addIdDemandInfo,
@@ -126,6 +130,7 @@ module Id (
 	mkIdEnv,
 	mkIdSet,
 	modifyIdEnv,
+	modifyIdEnv_Directly,
 	nullIdEnv,
 	rngIdEnv,
 	unionIdSets,
@@ -160,6 +165,8 @@ import PprType		( getTypeString, typeMaybeString, specMaybeTysSuffix,
 			)
 import PprStyle
 import Pretty
+import SpecEnv		( SpecEnv(..) )
+import MatchEnv		( MatchEnv )
 import SrcLoc		( mkBuiltinSrcLoc )
 import TyCon		( TyCon, mkTupleTyCon, tyConDataCons )
 import Type		( mkSigmaTy, mkTyVarTys, mkFunTys, mkDictTy,
@@ -778,46 +785,7 @@ unfoldingUnfriendlyId	-- return True iff it is definitely a bad
 	-> Bool		-- mentions this Id.  Reason: it cannot
 			-- possibly be seen in another module.
 
-unfoldingUnfriendlyId id = True -- ToDo:panic "Id.unfoldingUnfriendlyId"
-{-LATER:
-
-unfoldingUnfriendlyId id
-  | not (externallyVisibleId id) -- that settles that...
-  = True
-
-unfoldingUnfriendlyId (Id _ _ _ (WorkerId wrapper) _ _)
-  = class_thing wrapper
-  where
-    -- "class thing": If we're going to use this worker Id in
-    -- an interface, we *have* to be able to untangle the wrapper's
-    -- strictness when reading it back in.  At the moment, this
-    -- is not always possible: in precisely those cases where
-    -- we pass tcGenPragmas a "Nothing" for its "ty_maybe".
-
-    class_thing (Id _ _ _ (SuperDictSelId _ _) _ _)    = True
-    class_thing (Id _ _ _ (MethodSelId _ _) _ _)  	   = True
-    class_thing (Id _ _ _ (DefaultMethodId _ _ _) _ _) = True
-    class_thing other				   = False
-
-unfoldingUnfriendlyId (Id _ _ _ (SpecId d@(Id _ _ _ dfun@(DictFunId _ t _)) _ _) _ _)
-    -- a SPEC of a DictFunId can end up w/ gratuitous
-    -- TyVar(Templates) in the i/face; only a problem
-    -- if -fshow-pragma-name-errs; but we can do without the pain.
-    -- A HACK in any case (WDP 94/05/02)
-  = naughty_DictFunId dfun
-
-unfoldingUnfriendlyId d@(Id _ _ _ dfun@(DictFunId _ t _) _ _)
-  = naughty_DictFunId dfun -- similar deal...
-
-unfoldingUnfriendlyId other_id   = False -- is friendly in all other cases
-
-naughty_DictFunId :: IdDetails -> Bool
-    -- True <=> has a TyVar(Template) in the "type" part of its "name"
-
-naughty_DictFunId (DictFunId _ _ _) = panic "False" -- came from outside; must be OK
-naughty_DictFunId (DictFunId _ ty _)
-  = not (isGroundTy ty)
--}
+unfoldingUnfriendlyId id = not (externallyVisibleId id)
 \end{code}
 
 @externallyVisibleId@: is it true that another module might be
@@ -1482,9 +1450,8 @@ Notice the ``big lambdas'' and type arguments to @Con@---we are producing
 %************************************************************************
 
 @getIdUnfolding@ takes a @Id@ (we are discussing the @DataCon@ case)
-and generates an @UnfoldingDetails@ for its unfolding.  The @Ids@ and
-@TyVars@ don't really have to be new, because we are only producing a
-template.
+and generates an @Unfolding@.  The @Ids@ and @TyVars@ don't really
+have to be new, because we are only producing a template.
 
 ToDo: what if @DataConId@'s type has a context (haven't thought about it
 --WDP)?
@@ -1497,16 +1464,16 @@ dictionaries, in the even of an overloaded data-constructor---none at
 present.)
 
 \begin{code}
-getIdUnfolding :: Id -> UnfoldingDetails
+getIdUnfolding :: Id -> Unfolding
 
 getIdUnfolding (Id _ _ _ _ _ info) = getInfo_UF info
 
 {-LATER:
-addIdUnfolding :: Id -> UnfoldingDetails -> Id
+addIdUnfolding :: Id -> Unfolding -> Id
 addIdUnfolding id@(Id u n ty info details) unfold_details
   = ASSERT(
     	case (isLocallyDefined id, unfold_details) of
-	(_,     NoUnfoldingDetails) -> True
+	(_,     NoUnfolding) -> True
 	(True,  IWantToBeINLINEd _) -> True
 	(False, IWantToBeINLINEd _) -> False -- v bad
 	(False, _)  	    	    -> True
@@ -1574,14 +1541,12 @@ addIdFBTypeInfo (Id u n ty info details) upd_info
 \end{code}
 
 \begin{code}
-{- LATER:
 getIdSpecialisation :: Id -> SpecEnv
 getIdSpecialisation (Id _ _ _ _ _ info) = getInfo info
 
 addIdSpecialisation :: Id -> SpecEnv -> Id
 addIdSpecialisation (Id u n ty details prags info) spec_info
   = Id u n ty details prags (info `addInfo` spec_info)
--}
 \end{code}
 
 Strictness: we snaffle the info out of the IdInfo.
@@ -1712,7 +1677,7 @@ delManyFromIdEnv  :: IdEnv a -> [GenId ty] -> IdEnv a
 delOneFromIdEnv	  :: IdEnv a -> GenId ty -> IdEnv a
 combineIdEnvs	  :: (a -> a -> a) -> IdEnv a -> IdEnv a -> IdEnv a
 mapIdEnv	  :: (a -> b) -> IdEnv a -> IdEnv b
-modifyIdEnv	  :: IdEnv a -> (a -> a) -> GenId ty -> IdEnv a
+modifyIdEnv	  :: (a -> a) -> IdEnv a -> GenId ty -> IdEnv a
 rngIdEnv	  :: IdEnv a -> [a]
 		  
 isNullIdEnv	  :: IdEnv a -> Bool
@@ -1740,10 +1705,15 @@ lookupNoFailIdEnv env id    = case (lookupIdEnv env id) of { Just xx -> xx }
 -- modifyIdEnv: Look up a thing in the IdEnv, then mash it with the
 -- modify function, and put it back.
 
-modifyIdEnv env mangle_fn key
+modifyIdEnv mangle_fn env key
   = case (lookupIdEnv env key) of
       Nothing -> env
       Just xx -> addOneToIdEnv env key (mangle_fn xx)
+
+modifyIdEnv_Directly mangle_fn env key
+  = case (lookupUFM_Directly env key) of
+      Nothing -> env
+      Just xx -> addToUFM_Directly env key (mangle_fn xx)
 \end{code}
 
 \begin{code}
diff --git a/ghc/compiler/basicTypes/IdInfo.lhs b/ghc/compiler/basicTypes/IdInfo.lhs
index a0538b439f..0f7f0eb2ba 100644
--- a/ghc/compiler/basicTypes/IdInfo.lhs
+++ b/ghc/compiler/basicTypes/IdInfo.lhs
@@ -77,7 +77,6 @@ IMPORT_DELOOPER(IdLoop)	-- IdInfo is a dependency-loop ranch, and
 
 import CmdLineOpts	( opt_OmitInterfacePragmas )
 import Maybes		( firstJust )
-import MatchEnv		( nullMEnv, isEmptyMEnv, mEnvToList, MatchEnv )
 import Outputable	( ifPprInterface, Outputable(..){-instances-} )
 import PprStyle		( PprStyle(..) )
 import Pretty
@@ -117,16 +116,13 @@ data IdInfo
 	DemandInfo		-- Whether or not it is definitely
 				-- demanded
 
-	(MatchEnv [Type] CoreExpr)
-				-- Specialisations of this function which exist
-				-- This corresponds to a SpecEnv which we do
-				-- not import directly to avoid loop
+	SpecEnv			-- Specialisations of this function which exist
 
 	StrictnessInfo		-- Strictness properties, notably
 				-- how to conjure up "worker" functions
 
-	UnfoldingDetails	-- Its unfolding; for locally-defined
-				-- things, this can *only* be NoUnfoldingDetails
+	Unfolding		-- Its unfolding; for locally-defined
+				-- things, this can *only* be NoUnfolding
 
 	UpdateInfo		-- Which args should be updated
 
@@ -162,7 +158,7 @@ boringIdInfo (IdInfo UnknownArity
 		     _ {- no f/b w/w -}
 		     _ {- src_loc: no effect on interfaces-}
 	      )
-	      |  null (mEnvToList specenv)
+	      |  isNullSpecEnv specenv
 	      && boring_strictness strictness
 	      && boring_unfolding unfolding
   = True
@@ -171,8 +167,8 @@ boringIdInfo (IdInfo UnknownArity
     boring_strictness BottomGuaranteed = False
     boring_strictness (StrictnessInfo wrap_args _) = all_present_WwLazies wrap_args
 
-    boring_unfolding NoUnfoldingDetails = True
-    boring_unfolding _	    	    	= False
+    boring_unfolding NoUnfolding = True
+    boring_unfolding _	    	 = False
 
 boringIdInfo _ = False
 
@@ -185,7 +181,7 @@ nasty loop, friends...)
 \begin{code}
 apply_to_IdInfo ty_fn idinfo@(IdInfo arity demand spec strictness unfold
 			      update deforest arg_usage fb_ww srcloc)
-  | isEmptyMEnv spec
+  | isNullSpecEnv spec
   = idinfo
   | otherwise
   = panic "IdInfo:apply_to_IdInfo"
@@ -253,7 +249,7 @@ ppIdInfo :: PprStyle
 	 -> Id		-- The Id for which we're printing this IdInfo
 	 -> Bool	-- True <=> print specialisations, please
 	 -> (Id -> Id)	-- to look up "better Ids" w/ better IdInfos;
-	 -> IdEnv UnfoldingDetails
+	 -> IdEnv Unfolding
 			-- inlining info for top-level fns in this module
 	 -> IdInfo	-- see MkIface notes
 	 -> Pretty
@@ -279,8 +275,8 @@ ppIdInfo sty for_this_id specs_please better_id_fn inline_env
 		    else pp_unfolding sty for_this_id inline_env unfold,
 
 		    if specs_please
-		    then ppSpecs sty (not (isDataCon for_this_id))
-				 better_id_fn inline_env (mEnvToList specenv)
+		    then panic "ppSpecs (ToDo)" -- sty (not (isDataCon for_this_id))
+					 -- better_id_fn inline_env (mEnvToList specenv)
 		    else pp_NONE,
 
 		    -- DemandInfo needn't be printed since it has no effect on interfaces
@@ -414,19 +410,16 @@ instance OptIdInfo DemandInfo where
 See SpecEnv.lhs
 
 \begin{code}
-instance OptIdInfo (MatchEnv [Type] CoreExpr) where
-    noInfo = nullMEnv
+instance OptIdInfo SpecEnv where
+    noInfo = nullSpecEnv
 
     getInfo (IdInfo _ _ spec _ _ _ _ _ _ _) = spec
 
-    addInfo id_info spec | null (mEnvToList spec) = id_info
+    addInfo id_info spec | isNullSpecEnv spec = id_info
     addInfo (IdInfo a b _ d e f g h i j) spec = IdInfo a b spec d e f g h i j
 
-    ppInfo sty better_id_fn spec
-      = ppSpecs sty True better_id_fn nullIdEnv (mEnvToList spec)
-
-ppSpecs sty print_spec_id_info better_id_fn inline_env spec_env
-  = if null spec_env then ppNil else panic "IdInfo:ppSpecs"
+    ppInfo sty better_id_fn spec = panic "IdInfo:ppSpecs"
+--      = ppSpecs sty True better_id_fn nullIdEnv (mEnvToList spec)
 \end{code}
 
 %************************************************************************
@@ -737,25 +730,18 @@ pp_strictness sty for_this_id_maybe better_id_fn inline_env
 
 \begin{code}
 mkUnfolding guide expr
-  = GenForm (mkFormSummary NoStrictnessInfo expr)
-	(occurAnalyseGlobalExpr expr)
-	guide
+  = CoreUnfolding (SimpleUnfolding (mkFormSummary expr)
+				   guide
+				   (occurAnalyseGlobalExpr expr))
 \end{code}
 
 \begin{code}
-noInfo_UF = NoUnfoldingDetails
-
-getInfo_UF (IdInfo _ _ _ _ unfolding _ _ _ _ _)
-  = case unfolding of
-      GenForm _ _ BadUnfolding -> NoUnfoldingDetails
-      unfolding_as_was 	       -> unfolding_as_was
+noInfo_UF = NoUnfolding
 
--- getInfo_UF ensures that any BadUnfoldings are never returned
--- We had to delay the test required in TcPragmas until now due
--- to strictness constraints in TcPragmas
+getInfo_UF (IdInfo _ _ _ _ unfolding _ _ _ _ _) = unfolding
 
-addInfo_UF id_info@(IdInfo a b c d e f g h i j) NoUnfoldingDetails = id_info
-addInfo_UF   (IdInfo a b d e _ f g h i j) uf = IdInfo a b d e uf f g h i j
+addInfo_UF id_info@(IdInfo a b c d e f g h i j) NoUnfolding = id_info
+addInfo_UF (IdInfo a b d e _ f g h i j) uf = IdInfo a b d e uf f g h i j
 \end{code}
 
 \begin{code}
@@ -764,14 +750,12 @@ pp_unfolding sty for_this_id inline_env uf_details
       Nothing -> pp uf_details
       Just dt -> pp dt
   where
-    pp NoUnfoldingDetails = pp_NONE
+    pp NoUnfolding = pp_NONE
 
-    pp (MagicForm tag _)
+    pp (MagicUnfolding tag _)
       = ppCat [ppPStr SLIT("_MF_"), pprUnique tag]
 
-    pp (GenForm _ _ BadUnfolding) = pp_NONE
-
-    pp (GenForm _ template guide)
+    pp (CoreUnfolding (SimpleUnfolding _ guide template))
       = let
 	    untagged = unTagBinders template
 	in
diff --git a/ghc/compiler/basicTypes/IdLoop.lhi b/ghc/compiler/basicTypes/IdLoop.lhi
index 455902d4df..3a766f072e 100644
--- a/ghc/compiler/basicTypes/IdLoop.lhi
+++ b/ghc/compiler/basicTypes/IdLoop.lhi
@@ -8,14 +8,17 @@ import PreludeStdIO	( Maybe )
 
 import BinderInfo	( BinderInfo )
 import CoreSyn		( CoreExpr(..), GenCoreExpr, GenCoreArg )
-import CoreUnfold 	( FormSummary(..), UnfoldingDetails(..), UnfoldingGuidance(..) )
+import CoreUnfold 	( Unfolding(..), UnfoldingGuidance(..), 
+			  SimpleUnfolding(..), FormSummary(..)  )
 import CoreUtils	( unTagBinders )
 import Id		( externallyVisibleId, isDataCon, isWorkerId, isWrapperId,
 			  unfoldingUnfriendlyId, getIdInfo, nmbrId,
 			  nullIdEnv, lookupIdEnv, IdEnv(..),
 			  Id(..), GenId
 			)
+import CostCentre	( CostCentre )
 import IdInfo		( IdInfo )
+import SpecEnv		( SpecEnv, nullSpecEnv, isNullSpecEnv )
 import Literal		( Literal )
 import MagicUFs		( mkMagicUnfoldingFun, MagicUnfoldingFun )
 import OccurAnal	( occurAnalyseGlobalExpr )
@@ -32,6 +35,9 @@ import Usage		( GenUsage )
 import Util		( Ord3(..) )
 import WwLib		( mAX_WORKER_ARGS )
 
+nullSpecEnv   :: SpecEnv
+isNullSpecEnv :: SpecEnv -> Bool
+
 occurAnalyseGlobalExpr  :: GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenTyVar (GenUsage Unique)) Unique -> GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique), BinderInfo) (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenTyVar (GenUsage Unique)) Unique
 externallyVisibleId	:: Id	    -> Bool
 isDataCon		:: GenId ty -> Bool
@@ -62,20 +68,28 @@ instance Outputable (GenTyVar a)
 instance (Outputable a) => Outputable (GenId a)
 instance (Eq a, Outputable a, Eq b, Outputable b) => Outputable (GenType a b)
 
+data SpecEnv
 data NmbrEnv
 data MagicUnfoldingFun
-data FormSummary   = WhnfForm | BottomForm | OtherForm
-data UnfoldingDetails
-  = NoUnfoldingDetails
-  | OtherLitForm [Literal]
-  | OtherConForm [GenId (GenType (GenTyVar (GenUsage Unique)) Unique)]
-  | GenForm FormSummary (GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique), BinderInfo) (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenTyVar (GenUsage Unique)) Unique) UnfoldingGuidance
-  | MagicForm Unique MagicUnfoldingFun
+data FormSummary = VarForm | ValueForm | BottomForm | OtherForm
+
+data Unfolding
+  = NoUnfolding
+  | CoreUnfolding SimpleUnfolding
+  | MagicUnfolding Unique MagicUnfoldingFun
+
+
+data SimpleUnfolding = SimpleUnfolding FormSummary UnfoldingGuidance (GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique), BinderInfo) (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenTyVar (GenUsage Unique)) Unique) 
+
 
 data UnfoldingGuidance
   = UnfoldNever
   | UnfoldAlways
-  | EssentialUnfolding
   | UnfoldIfGoodArgs Int Int [Bool] Int
-  | BadUnfolding
+
+data CostCentre
 \end{code}
+
+
+
+
diff --git a/ghc/compiler/basicTypes/IdLoop_1_3.lhi b/ghc/compiler/basicTypes/IdLoop_1_3.lhi
index 9de57ba226..38ee2b9d0a 100644
--- a/ghc/compiler/basicTypes/IdLoop_1_3.lhi
+++ b/ghc/compiler/basicTypes/IdLoop_1_3.lhi
@@ -3,7 +3,7 @@ interface IdLoop_1_3 1
 __exports__
 CoreSyn CoreExpr
 CoreUnfold FormSummary (..)
-CoreUnfold UnfoldingDetails (..)
+CoreUnfold Unfolding (..)
 CoreUnfold UnfoldingGuidance (..)
 CoreUtils unTagBinders (..)
 Id IdEnv
@@ -19,5 +19,7 @@ MagicUFs MagicUnfoldingFun
 MagicUFs mkMagicUnfoldingFun (..)
 OccurAnal occurAnalyseGlobalExpr (..)
 PprType pprParendGenType (..)
+SpecEnv  isNullSpecEnv (..)
+SpecEnv  nullSpecEnv (..)
 WwLib mAX_WORKER_ARGS (..)
 \end{code}
diff --git a/ghc/compiler/basicTypes/IdUtils.lhs b/ghc/compiler/basicTypes/IdUtils.lhs
index 167a231670..12c8d34d54 100644
--- a/ghc/compiler/basicTypes/IdUtils.lhs
+++ b/ghc/compiler/basicTypes/IdUtils.lhs
@@ -12,9 +12,10 @@ IMP_Ubiq()
 IMPORT_DELOOPER(PrelLoop)		-- here for paranoia checking
 
 import CoreSyn
-import CoreUnfold	( UnfoldingGuidance(..) )
+import CoreUnfold	( UnfoldingGuidance(..), Unfolding )
 import Id		( mkImported, mkTemplateLocals )
 import IdInfo		-- quite a few things
+import SpecEnv		( SpecEnv )
 import Name		( mkPrimitiveName, OrigName(..) )
 import PrelMods		( gHC_BUILTINS )
 import PrimOp		( primOpInfo, tagOf_PrimOp, primOp_str,
@@ -63,7 +64,7 @@ primOpId op
     mk_prim_Id prim_op name tyvar_tmpls arg_tys ty arity
       = mkImported (mkPrimitiveName key (OrigName gHC_BUILTINS name)) ty
 	   (noIdInfo `addInfo` (mkArityInfo arity)
-	          `addInfo_UF` (mkUnfolding EssentialUnfolding
+	          `addInfo_UF` (mkUnfolding UnfoldAlways
 			         (mk_prim_unfold prim_op tyvar_tmpls arg_tys)))
       where
 	key = mkPrimOpIdUnique (IBOX(tagOf_PrimOp prim_op))
diff --git a/ghc/compiler/codeGen/CgMonad.lhs b/ghc/compiler/codeGen/CgMonad.lhs
index dff65e5446..2b23b93290 100644
--- a/ghc/compiler/codeGen/CgMonad.lhs
+++ b/ghc/compiler/codeGen/CgMonad.lhs
@@ -670,7 +670,7 @@ addBindsC new_bindings info_down (MkCgState absC binds usage)
 \begin{code}
 modifyBindC :: Id -> (CgIdInfo -> CgIdInfo) -> Code
 modifyBindC name mangle_fn info_down (MkCgState absC binds usage)
-  = MkCgState absC (modifyIdEnv binds mangle_fn name) usage
+  = MkCgState absC (modifyIdEnv mangle_fn binds name) usage
 \end{code}
 
 Lookup is expected to find a binding for the @Id@.
diff --git a/ghc/compiler/coreSyn/CoreSyn.lhs b/ghc/compiler/coreSyn/CoreSyn.lhs
index 854969b9e8..42830e9008 100644
--- a/ghc/compiler/coreSyn/CoreSyn.lhs
+++ b/ghc/compiler/coreSyn/CoreSyn.lhs
@@ -18,9 +18,10 @@ module CoreSyn (
 	mkApp, mkCon, mkPrim,
 	mkValLam, mkTyLam, mkUseLam,
 	mkLam,
-	collectBinders, isValBinder, notValBinder,
+	collectBinders, collectUsageAndTyBinders, collectValBinders, 
+	isValBinder, notValBinder,
 	
-	collectArgs, isValArg, notValArg, numValArgs,
+	collectArgs, initialTyArgs, initialValArgs, isValArg, notValArg, numValArgs,
 
 	mkCoLetAny, mkCoLetNoUnboxed, mkCoLetUnboxedToCase,
 	mkCoLetsAny, mkCoLetsNoUnboxed, mkCoLetsUnboxedToCase,
@@ -224,13 +225,8 @@ mkCoLetrecAny binds body = Let (Rec binds) body
 mkCoLetsAny []    expr = expr
 mkCoLetsAny binds expr = foldr mkCoLetAny expr binds
 
-mkCoLetAny bind@(Rec binds) body = mkCoLetrecAny binds body
-mkCoLetAny bind@(NonRec binder rhs) body
-  = case body of
-      Var binder2 | binder == binder2
-	 -> rhs   -- hey, I have the rhs
-      other
-	 -> Let bind body
+mkCoLetAny bind@(Rec binds)         body = mkCoLetrecAny binds body
+mkCoLetAny bind@(NonRec binder rhs) body = Let bind body
 \end{code}
 
 \begin{code}
@@ -384,24 +380,24 @@ collectBinders ::
   ([uvar], [tyvar], [val_bdr], GenCoreExpr val_bdr val_occ tyvar uvar)
 
 collectBinders expr
+  = (usages, tyvars, vals, body)
+  where
+    (usages, tyvars, body1) = collectUsageAndTyBinders expr
+    (vals, body) 	    = collectValBinders body1
+
+
+collectUsageAndTyBinders expr
   = usages expr []
   where
     usages (Lam (UsageBinder u) body) uacc = usages body (u:uacc)
     usages other uacc
-      = case (tyvars other []) of { (tacc, vacc, expr) ->
-	(reverse uacc, tacc, vacc, expr) }
+      = case (tyvars other []) of { (tacc, expr) ->
+	(reverse uacc, tacc, expr) }
 
-    tyvars (Lam (TyBinder t)    body) tacc = tyvars body (t:tacc)
+    tyvars (Lam (TyBinder t) body) tacc = tyvars body (t:tacc)
     tyvars other tacc
       = ASSERT(not (usage_lambda other))
-	case (valvars other []) of { (vacc, expr) ->
-	(reverse tacc, vacc, expr) }
-
-    valvars (Lam (ValBinder v)  body) vacc = valvars body (v:vacc)
-    valvars other vacc
-      = ASSERT(not (usage_lambda other))
-	ASSERT(not (tyvar_lambda other))
-	(reverse vacc, other)
+	(reverse tacc, other)
 
     ---------------------------------------
     usage_lambda (Lam (UsageBinder _) _) = True
@@ -409,6 +405,16 @@ collectBinders expr
 
     tyvar_lambda (Lam (TyBinder _) _)    = True
     tyvar_lambda _			 = False
+
+
+collectValBinders :: GenCoreExpr val_bdr val_occ tyvar uvar ->
+		     ([val_bdr], GenCoreExpr val_bdr val_occ tyvar uvar)
+collectValBinders expr
+  = go [] expr
+  where
+    go acc (Lam (ValBinder v) b) = go (v:acc) b
+    go acc body 		 = (reverse acc, body)
+
 \end{code}
 
 %************************************************************************
@@ -498,6 +504,21 @@ collectArgs expr
       = (fun,uacc)
 \end{code}
 
+
+\begin{code}
+initialTyArgs :: [GenCoreArg val_occ tyvar uvar]
+	      -> ([GenType tyvar uvar], [GenCoreArg val_occ tyvar uvar])
+initialTyArgs (TyArg ty : args) = (ty:tys, args') 
+				where
+				  (tys, args') = initialTyArgs args
+initialTyArgs other 		= ([],other)
+
+initialValArgs :: [GenCoreArg val_occ tyvar uvar]
+	      -> ([GenCoreArg val_occ tyvar uvar], [GenCoreArg val_occ tyvar uvar])
+initialValArgs args = span isValArg args
+\end{code}
+
+
 %************************************************************************
 %*									*
 \subsection{The main @Core*@ instantiation of the @GenCore*@ types}
diff --git a/ghc/compiler/coreSyn/CoreUnfold.lhs b/ghc/compiler/coreSyn/CoreUnfold.lhs
index 9090e7702e..37eede1e4e 100644
--- a/ghc/compiler/coreSyn/CoreUnfold.lhs
+++ b/ghc/compiler/coreSyn/CoreUnfold.lhs
@@ -6,22 +6,23 @@
 Unfoldings (which can travel across module boundaries) are in Core
 syntax (namely @CoreExpr@s).
 
-The type @UnfoldingDetails@ sits ``above'' simply-Core-expressions
+The type @Unfolding@ sits ``above'' simply-Core-expressions
 unfoldings, capturing ``higher-level'' things we know about a binding,
 usually things that the simplifier found out (e.g., ``it's a
-literal'').  In the corner of a @GenForm@ unfolding, you will
+literal'').  In the corner of a @SimpleUnfolding@ unfolding, you will
 find, unsurprisingly, a Core expression.
 
 \begin{code}
 #include "HsVersions.h"
 
 module CoreUnfold (
-	UnfoldingDetails(..), UnfoldingGuidance(..), -- types
-	FormSummary(..),
+	SimpleUnfolding(..), Unfolding(..), UnfoldingGuidance(..), -- types
 
-	mkFormSummary,
-	mkGenForm, mkLitForm, mkConForm,
-	whnfDetails,
+	FormSummary(..), mkFormSummary, whnfOrBottom, exprSmallEnoughToDup,
+
+	smallEnoughToInline, couldBeSmallEnoughToInline,
+
+	mkSimpleUnfolding,
 	mkMagicUnfolding,
 	calcUnfoldingGuidance,
 	mentionedInUnfolding
@@ -33,16 +34,17 @@ IMPORT_DELOOPER(IdLoop)	 -- for paranoia checking;
 IMPORT_DELOOPER(PrelLoop)  -- for paranoia checking
 
 import Bag		( emptyBag, unitBag, unionBags, Bag )
-import BinderInfo	( oneTextualOcc, oneSafeOcc )
 import CgCompInfo	( uNFOLDING_CHEAP_OP_COST,
 			  uNFOLDING_DEAR_OP_COST,
 			  uNFOLDING_NOREP_LIT_COST
 			)
 import CoreSyn
-import CoreUtils	( coreExprType, manifestlyWHNF )
+import CoreUtils	( coreExprType )
 import CostCentre	( ccMentionsId )
-import Id		( SYN_IE(IdSet), GenId{-instances-} )
-import IdInfo		( bottomIsGuaranteed )
+import Id		( idType, getIdArity,  isBottomingId, 
+			  SYN_IE(IdSet), GenId{-instances-} )
+import PrimOp		( fragilePrimOp, PrimOp(..) )
+import IdInfo		( arityMaybe, bottomIsGuaranteed )
 import Literal		( isNoRepLit, isLitLitLit )
 import Pretty
 import PrimOp		( primOpCanTriggerGC, PrimOp(..) )
@@ -52,7 +54,7 @@ import UniqSet		( emptyUniqSet, unitUniqSet, mkUniqSet,
 			  addOneToUniqSet, unionUniqSets
 			)
 import Usage		( SYN_IE(UVar) )
-import Util		( isIn, panic )
+import Util		( isIn, panic, assertPanic )
 
 whatsMentionedInId = panic "whatsMentionedInId (CoreUnfold)"
 getMentionedTyConsAndClassesFromType = panic "getMentionedTyConsAndClassesFromType (CoreUnfold)"
@@ -60,150 +62,144 @@ getMentionedTyConsAndClassesFromType = panic "getMentionedTyConsAndClassesFromTy
 
 %************************************************************************
 %*									*
-\subsection{@UnfoldingDetails@ and @UnfoldingGuidance@ types}
+\subsection{@Unfolding@ and @UnfoldingGuidance@ types}
 %*									*
 %************************************************************************
 
-(And @FormSummary@, too.)
-
 \begin{code}
-data UnfoldingDetails
-  = NoUnfoldingDetails
-
-  | OtherLitForm
-	[Literal]		-- It is a literal, but definitely not one of these
-
-  | OtherConForm
-	[Id]			-- It definitely isn't one of these constructors
-				-- This captures the situation in the default branch of
-				-- a case:  case x of
-				--		c1 ... -> ...
-				--		c2 ... -> ...
-				--		v -> default-rhs
-				-- Then in default-rhs we know that v isn't c1 or c2.
-				--
-				-- NB.  In the degenerate: case x of {v -> default-rhs}
-				-- x will be bound to
-				--	OtherConForm []
-				-- which captures the idea that x is eval'd but we don't
-				-- know which constructor.
-
-
-  | GenForm
-	FormSummary		-- Tells whether the template is a WHNF or bottom
-	TemplateOutExpr		-- The template
-	UnfoldingGuidance	-- Tells about the *size* of the template.
-
-  | MagicForm
+data Unfolding
+  = NoUnfolding
+  | CoreUnfolding SimpleUnfolding
+  | MagicUnfolding
 	Unique			-- of the Id whose magic unfolding this is
 	MagicUnfoldingFun
 
+
+data SimpleUnfolding
+  = SimpleUnfolding	FormSummary		-- Tells whether the template is a WHNF or bottom
+			UnfoldingGuidance	-- Tells about the *size* of the template.
+			TemplateOutExpr		-- The template
+
 type TemplateOutExpr = GenCoreExpr (Id, BinderInfo) Id TyVar UVar
 	-- An OutExpr with occurrence info attached.  This is used as
 	-- a template in GeneralForms.
 
-mkMagicUnfolding :: Unique -> UnfoldingDetails
-mkMagicUnfolding tag  = MagicForm tag (mkMagicUnfoldingFun tag)
 
-data FormSummary
-  = WhnfForm 		-- Expression is WHNF
-  | BottomForm		-- Expression is guaranteed to be bottom. We're more gung
-			-- ho about inlining such things, because it can't waste work
-  | OtherForm		-- Anything else
+mkSimpleUnfolding form guidance    template 
+  = SimpleUnfolding form guidance template
 
-instance Outputable FormSummary where
-   ppr sty WhnfForm   = ppStr "WHNF"
-   ppr sty BottomForm = ppStr "Bot"
-   ppr sty OtherForm  = ppStr "Other"
+mkMagicUnfolding :: Unique -> Unfolding
+mkMagicUnfolding tag  = MagicUnfolding tag (mkMagicUnfoldingFun tag)
 
---???mkFormSummary :: StrictnessInfo -> GenCoreExpr bndr Id -> FormSummary
-mkFormSummary si expr
-  | manifestlyWHNF     expr = WhnfForm
-  | bottomIsGuaranteed si   = BottomForm
-
-  -- Chances are that the Id will be decorated with strictness info
-  -- telling that the RHS is definitely bottom.  This *might* not be the
-  -- case, if it's been a while since strictness analysis, but leaving out
-  -- the test for manifestlyBottom makes things a little more efficient.
-  -- We can always put it back...
-  -- | manifestlyBottom expr  = BottomForm
-
-  | otherwise = OtherForm
-
-whnfDetails :: UnfoldingDetails -> Bool		-- True => thing is evaluated
-whnfDetails (GenForm WhnfForm _ _) = True
-whnfDetails (OtherLitForm _)	   = True
-whnfDetails (OtherConForm _)	   = True
-whnfDetails other		   = False
-\end{code}
 
-\begin{code}
 data UnfoldingGuidance
-  = UnfoldNever			-- Don't do it!
-
+  = UnfoldNever
   | UnfoldAlways		-- There is no "original" definition,
 				-- so you'd better unfold.  Or: something
 				-- so cheap to unfold (e.g., 1#) that
 				-- you should do it absolutely always.
 
-  | EssentialUnfolding		-- Like UnfoldAlways, but you *must* do
-				-- it absolutely always.
-				-- This is what we use for data constructors
-				-- and PrimOps, because we don't feel like
-				-- generating curried versions "just in case".
-
-  | UnfoldIfGoodArgs	Int	-- if "m" type args and "n" value args; and
-			Int	-- those val args are manifestly data constructors
-			[Bool]	-- the val-arg positions marked True
+  | UnfoldIfGoodArgs	Int	-- if "m" type args 
+			Int	-- and "n" value args
+			[Int]	-- Discount if the argument is evaluated.
 				-- (i.e., a simplification will definitely
-				-- be possible).
+				-- be possible).  One elt of the list per *value* arg.
 			Int	-- The "size" of the unfolding; to be elaborated
 				-- later. ToDo
-
-  | BadUnfolding		-- This is used by TcPragmas if the *lazy*
-				-- lintUnfolding test fails
-				-- It will never escape from the IdInfo as
-				-- it is caught by getInfo_UF and converted
-				-- to NoUnfoldingDetails
 \end{code}
 
 \begin{code}
 instance Outputable UnfoldingGuidance where
-    ppr sty UnfoldNever	    	= ppStr "_N_"
     ppr sty UnfoldAlways    	= ppStr "_ALWAYS_"
-    ppr sty EssentialUnfolding	= ppStr "_ESSENTIAL_" -- shouldn't appear in an iface
+--    ppr sty EssentialUnfolding	= ppStr "_ESSENTIAL_" -- shouldn't appear in an iface
     ppr sty (UnfoldIfGoodArgs t v cs size)
       = ppCat [ppStr "_IF_ARGS_", ppInt t, ppInt v,
 	       if null cs	-- always print *something*
 	       	then ppChar 'X'
-		else ppBesides (map pp_c cs),
+		else ppBesides (map (ppStr . show) cs),
 	       ppInt size ]
-      where
-	pp_c False = ppChar 'X'
-	pp_c True  = ppChar 'C'
 \end{code}
 
 
 %************************************************************************
 %*									*
-\subsection{@mkGenForm@ and friends}
+\subsection{Figuring out things about expressions}
 %*									*
 %************************************************************************
 
 \begin{code}
-mkGenForm :: FormSummary
-	  -> TemplateOutExpr	-- Template
-	  -> UnfoldingGuidance	-- Tells about the *size* of the template.
-	  -> UnfoldingDetails
+data FormSummary
+  = VarForm		-- Expression is a variable (or scc var, etc)
+  | ValueForm		-- Expression is a value: i.e. a value-lambda,constructor, or literal
+  | BottomForm		-- Expression is guaranteed to be bottom. We're more gung
+			-- ho about inlining such things, because it can't waste work
+  | OtherForm		-- Anything else
+
+instance Outputable FormSummary where
+   ppr sty VarForm    = ppStr "Var"
+   ppr sty ValueForm  = ppStr "Value"
+   ppr sty BottomForm = ppStr "Bot"
+   ppr sty OtherForm  = ppStr "Other"
+
+mkFormSummary ::GenCoreExpr bndr Id tyvar uvar -> FormSummary
 
-mkGenForm = GenForm
+mkFormSummary expr
+  = go (0::Int) expr		-- The "n" is the number of (value) arguments so far
+  where
+    go n (Lit _)	= ASSERT(n==0) ValueForm
+    go n (Con _ _)      = ASSERT(n==0) ValueForm
+    go n (SCC _ e)      = go n e
+    go n (Coerce _ _ e) = go n e
+    go n (Let _ e)      = OtherForm
+    go n (Case _ _)     = OtherForm
+
+    go 0 (Lam (ValBinder x) e) = ValueForm	-- NB: \x.bottom /= bottom!
+    go n (Lam (ValBinder x) e) = go (n-1) e	-- Applied lambda
+    go n (Lam other_binder e)  = go n e
+
+    go n (App fun arg) | isValArg arg = go (n+1) fun
+    go n (App fun other_arg)          = go n fun
+
+    go n (Var f) | isBottomingId f = BottomForm
+    go 0 (Var f)		   = VarForm
+    go n (Var f)		   = case (arityMaybe (getIdArity f)) of
+					  Just arity | n < arity -> ValueForm
+					  other			 -> OtherForm
+
+whnfOrBottom :: GenCoreExpr bndr Id tyvar uvar -> Bool
+whnfOrBottom e = case mkFormSummary e of 
+			VarForm    -> True
+			ValueForm  -> True
+			BottomForm -> True
+			OtherForm  -> False
+\end{code}
 
--- two shorthand variants:
-mkLitForm lit      = mk_go_for_it (Lit lit)
-mkConForm con args = mk_go_for_it (Con con args)
 
-mk_go_for_it expr = mkGenForm WhnfForm expr UnfoldAlways
+\begin{code}
+exprSmallEnoughToDup (Con _ _)   = True	-- Could check # of args
+exprSmallEnoughToDup (Prim op _) = not (fragilePrimOp op) -- Could check # of args
+exprSmallEnoughToDup (Lit lit)   = not (isNoRepLit lit)
+exprSmallEnoughToDup expr
+  = case (collectArgs expr) of { (fun, _, _, vargs) ->
+    case fun of
+      Var v | length vargs == 0 -> True
+      _				-> False
+    }
+
+{- LATER:
+WAS: MORE CLEVER:
+exprSmallEnoughToDup expr  -- for now, just: <var> applied to <args>
+  = case (collectArgs expr) of { (fun, _, _, vargs) ->
+    case fun of
+      Var v -> v /= buildId
+		 && v /= augmentId
+		 && length vargs <= 6 -- or 10 or 1 or 4 or anything smallish.
+      _       -> False
+    }
+-}
 \end{code}
+Question (ADR): What is the above used for?  Is a _ccall_ really small
+enough?
 
 %************************************************************************
 %*									*
@@ -213,9 +209,9 @@ mk_go_for_it expr = mkGenForm WhnfForm expr UnfoldAlways
 
 \begin{code}
 calcUnfoldingGuidance
-	:: Bool		    -- True <=> OK if _scc_s appear in expr
-	-> Int		    -- bomb out if size gets bigger than this
-	-> CoreExpr    -- expression to look at
+	:: Bool		    	-- True <=> OK if _scc_s appear in expr
+	-> Int		    	-- bomb out if size gets bigger than this
+	-> CoreExpr    		-- expression to look at
 	-> UnfoldingGuidance
 
 calcUnfoldingGuidance scc_s_OK bOMB_OUT_SIZE expr
@@ -231,8 +227,12 @@ calcUnfoldingGuidance scc_s_OK bOMB_OUT_SIZE expr
 	       uf = UnfoldIfGoodArgs
 			(length ty_binders)
 			(length val_binders)
-			[ b `is_elem` cased_args | b <- val_binders ]
+			(map discount_for val_binders)
 			size
+	       discount_for b | b `is_elem` cased_args = tyConFamilySize tycon
+			      | otherwise	       = 0
+			      where
+				(tycon, _, _) = getAppDataTyConExpandingDicts (idType b)
 	   in
 	   -- pprTrace "calcUnfold:" (ppAbove (ppr PprDebug uf) (ppr PprDebug expr))
 	   uf
@@ -316,7 +316,7 @@ sizeExpr scc_s_OK bOMB_OUT_SIZE args expr
 	size_alg_alt (con,args,rhs) = size_up rhs
 	    -- Don't charge for args, so that wrappers look cheap
 
-	(tycon, _, _) = --trace "CoreUnfold.getAppDataTyConExpandingDicts" $
+	(tycon, _, _) = --trace "CoreUnfold.getAppDataTyConExpandingDicts" $ 
 			getAppDataTyConExpandingDicts scrut_ty
 
     size_up_alts _ (PrimAlts alts deflt)
@@ -366,6 +366,61 @@ sizeExpr scc_s_OK bOMB_OUT_SIZE args expr
 
 %************************************************************************
 %*									*
+\subsection[considerUnfolding]{Given all the info, do (not) do the unfolding}
+%*									*
+%************************************************************************
+
+We have very limited information about an unfolding expression: (1)~so
+many type arguments and so many value arguments expected---for our
+purposes here, we assume we've got those.  (2)~A ``size'' or ``cost,''
+a single integer.  (3)~An ``argument info'' vector.  For this, what we
+have at the moment is a Boolean per argument position that says, ``I
+will look with great favour on an explicit constructor in this
+position.''
+
+Assuming we have enough type- and value arguments (if not, we give up
+immediately), then we see if the ``discounted size'' is below some
+(semi-arbitrary) threshold.  It works like this: for every argument
+position where we're looking for a constructor AND WE HAVE ONE in our
+hands, we get a (again, semi-arbitrary) discount [proportion to the
+number of constructors in the type being scrutinized].
+
+\begin{code}
+smallEnoughToInline :: Int -> Int	-- Constructor discount and size threshold
+	      -> [Bool]			-- Evaluated-ness of value arguments
+	      -> UnfoldingGuidance
+	      -> Bool			-- True => unfold it
+
+smallEnoughToInline con_discount size_threshold _ UnfoldAlways = True
+smallEnoughToInline con_discount size_threshold _ UnfoldNever  = False
+smallEnoughToInline con_discount size_threshold arg_is_evald_s
+	      (UnfoldIfGoodArgs m_tys_wanted n_vals_wanted discount_vec size)
+  = n_vals_wanted <= length arg_is_evald_s &&
+    discounted_size <= size_threshold
+
+  where
+    discounted_size = size - sum (zipWith arg_discount discount_vec arg_is_evald_s)
+
+    arg_discount no_of_constrs is_evald
+      | is_evald  = 1 + no_of_constrs * con_discount
+      | otherwise = 1
+\end{code}
+
+We use this one to avoid exporting inlinings that we ``couldn't possibly
+use'' on the other side.  Can be overridden w/ flaggery.
+Just the same as smallEnoughToInline, except that it has no actual arguments.
+
+\begin{code}
+couldBeSmallEnoughToInline :: Int -> Int	-- Constructor discount and size threshold
+	      	       	   -> UnfoldingGuidance
+		      	   -> Bool		-- True => unfold it
+
+couldBeSmallEnoughToInline con_discount size_threshold guidance
+  = smallEnoughToInline con_discount size_threshold (repeat True) guidance
+\end{code}
+
+%************************************************************************
+%*									*
 \subsection[unfoldings-for-ifaces]{Processing unfoldings for interfaces}
 %*									*
 %************************************************************************
diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs
index 2000b32f85..9bc5a17002 100644
--- a/ghc/compiler/coreSyn/CoreUtils.lhs
+++ b/ghc/compiler/coreSyn/CoreUtils.lhs
@@ -7,18 +7,17 @@
 #include "HsVersions.h"
 
 module CoreUtils (
-	coreExprType, coreAltsType,
+	coreExprType, coreAltsType, coreExprCc,
 
 	substCoreExpr, substCoreBindings
 
 	, mkCoreIfThenElse
 	, argToExpr
 	, unTagBinders, unTagBindersAlts
-	, manifestlyWHNF, manifestlyBottom
+
 	, maybeErrorApp
 	, nonErrorRHSs
 	, squashableDictishCcExpr
-	, exprSmallEnoughToDup
 {-	
 	coreExprArity,
 	isWrapperFor,
@@ -30,7 +29,7 @@ IMPORT_DELOOPER(IdLoop)	-- for pananoia-checking purposes
 
 import CoreSyn
 
-import CostCentre	( isDictCC )
+import CostCentre	( isDictCC, CostCentre, noCostCentre )
 import Id		( idType, mkSysLocal, getIdArity, isBottomingId,
 			  toplevelishId, mkIdWithNewUniq, applyTypeEnvToId,
 			  addOneToIdEnv, growIdEnvList, lookupIdEnv,
@@ -43,9 +42,9 @@ import Maybes		( catMaybes, maybeToBool )
 import PprCore
 import PprStyle		( PprStyle(..) )
 import PprType		( GenType{-instances-} )
-import Pretty		( ppAboves )
+import Pretty		( ppAboves, ppStr )
 import PrelVals		( augmentId, buildId )
-import PrimOp		( primOpType, fragilePrimOp, PrimOp(..) )
+import PrimOp		( primOpType, PrimOp(..) )
 import SrcLoc		( mkUnknownSrcLoc )
 import TyVar		( cloneTyVar,
 			  isNullTyVarEnv, addOneToTyVarEnv, SYN_IE(TyVarEnv)
@@ -141,6 +140,16 @@ applyTypeToArg op_ty val_or_lit_arg = case (getFunTy_maybe op_ty) of
 					Just (_, res_ty) -> res_ty
 \end{code}
 
+coreExprCc gets the cost centre enclosing an expression, if any.
+It looks inside lambdas because (scc "foo" \x.e) = \x.scc "foo" e
+
+\begin{code}
+coreExprCc :: GenCoreExpr val_bdr val_occ tyvar uvar -> CostCentre
+coreExprCc (SCC cc e) = cc
+coreExprCc (Lam _ e)  = coreExprCc e
+coreExprCc other      = noCostCentre
+\end{code}
+
 %************************************************************************
 %*									*
 \subsection{Routines to manufacture bits of @CoreExpr@}
@@ -213,112 +222,6 @@ argToExpr (LitArg lit) = Lit lit
 \end{code}
 
 \begin{code}
-exprSmallEnoughToDup (Con _ _)   = True	-- Could check # of args
-exprSmallEnoughToDup (Prim op _) = not (fragilePrimOp op) -- Could check # of args
-exprSmallEnoughToDup (Lit lit)   = not (isNoRepLit lit)
-exprSmallEnoughToDup expr
-  = case (collectArgs expr) of { (fun, _, _, vargs) ->
-    case fun of
-      Var v | length vargs == 0 -> True
-      _				-> False
-    }
-
-{- LATER:
-WAS: MORE CLEVER:
-exprSmallEnoughToDup expr  -- for now, just: <var> applied to <args>
-  = case (collectArgs expr) of { (fun, _, _, vargs) ->
-    case fun of
-      Var v -> v /= buildId
-		 && v /= augmentId
-		 && length vargs <= 6 -- or 10 or 1 or 4 or anything smallish.
-      _       -> False
-    }
--}
-\end{code}
-Question (ADR): What is the above used for?  Is a _ccall_ really small
-enough?
-
-@manifestlyWHNF@ looks at a Core expression and returns \tr{True} if
-it is obviously in weak head normal form.  It isn't a disaster if it
-errs on the conservative side (returning \tr{False})---I've probably
-left something out... [WDP]
-
-\begin{code}
-manifestlyWHNF :: GenCoreExpr bndr Id tyvar uvar -> Bool
-
-manifestlyWHNF (Var _)	      = True
-manifestlyWHNF (Lit _)	      = True
-manifestlyWHNF (Con _ _)      = True
-manifestlyWHNF (SCC _ e)      = manifestlyWHNF e
-manifestlyWHNF (Coerce _ _ e) = manifestlyWHNF e
-manifestlyWHNF (Let _ e)      = False
-manifestlyWHNF (Case _ _)     = False
-
-manifestlyWHNF (Lam x e)  = if isValBinder x then True else manifestlyWHNF e
-
-manifestlyWHNF other_expr   -- look for manifest partial application
-  = case (collectArgs other_expr) of { (fun, _, _, vargs) ->
-    case fun of
-      Var f ->  let
-		    num_val_args = length vargs
-		in
-		num_val_args == 0 -- Just a type application of
-				  -- a variable (f t1 t2 t3);
-				  -- counts as WHNF.
-		||
-		case (arityMaybe (getIdArity f)) of
-		  Nothing     -> False
-		  Just arity  -> num_val_args < arity
-
-      _ -> False
-    }
-\end{code}
-
-@manifestlyBottom@ looks at a Core expression and returns \tr{True} if
-it is obviously bottom, that is, it will certainly return bottom at
-some point.  It isn't a disaster if it errs on the conservative side
-(returning \tr{False}).
-
-\begin{code}
-manifestlyBottom :: GenCoreExpr bndr Id tyvar uvar -> Bool
-
-manifestlyBottom (Var v)     	= isBottomingId v
-manifestlyBottom (Lit _)     	= False
-manifestlyBottom (Con  _ _)  	= False
-manifestlyBottom (Prim _ _)  	= False
-manifestlyBottom (SCC _ e)   	= manifestlyBottom e
-manifestlyBottom (Coerce _ _ e) = manifestlyBottom e
-manifestlyBottom (Let _ e)	= manifestlyBottom e
-
-  -- We do not assume \x.bottom == bottom:
-manifestlyBottom (Lam x e) = if isValBinder x then False else manifestlyBottom e
-
-manifestlyBottom (Case e a)
-  = manifestlyBottom e
-  || (case a of
-	AlgAlts  alts def -> all mbalg  alts && mbdef def
-	PrimAlts alts def -> all mbprim alts && mbdef def
-     )
-  where
-    mbalg  (_,_,e') = manifestlyBottom e'
-
-    mbprim (_,e')   = manifestlyBottom e'
-
-    mbdef NoDefault          = True
-    mbdef (BindDefault _ e') = manifestlyBottom e'
-
-manifestlyBottom other_expr   -- look for manifest partial application
-  = case (collectArgs other_expr) of { (fun, _, _, _) ->
-    case fun of
-      Var f | isBottomingId f -> True
-		-- Application of a function which always gives
-		-- bottom; we treat this as a WHNF, because it
-		-- certainly doesn't need to be shared!
-      _ -> False
-    }
-\end{code}
-
-\begin{code}
 {-LATER:
 coreExprArity
 	:: (Id -> Maybe (GenCoreExpr bndr Id))
diff --git a/ghc/compiler/coreSyn/PprCore.lhs b/ghc/compiler/coreSyn/PprCore.lhs
index fba4be2374..e9bb179089 100644
--- a/ghc/compiler/coreSyn/PprCore.lhs
+++ b/ghc/compiler/coreSyn/PprCore.lhs
@@ -31,6 +31,7 @@ import Id		( idType, getIdInfo, getIdStrictness, isTupleCon,
 			  nullIdEnv, SYN_IE(DataCon), GenId{-instances-}
 			)
 import IdInfo		( ppIdInfo, StrictnessInfo(..) )
+import IdLoop		( Unfolding )	-- Needed by IdInfo.hi?
 import Literal		( Literal{-instances-} )
 import Name		( isSymLexeme )
 import Outputable	-- quite a few things
@@ -387,7 +388,7 @@ pprBigCoreBinder sty binder
 
     pragmas =
 	ifnotPprForUser sty
-	 (ppIdInfo sty binder True{-specs, please-} id nullIdEnv
+	 (ppIdInfo sty binder False{-no specs, thanks-} id nullIdEnv
 	  (getIdInfo binder))
 
 pprBabyCoreBinder sty binder
diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs
index e8f4398cc3..b2adec7fa5 100644
--- a/ghc/compiler/deSugar/DsExpr.lhs
+++ b/ghc/compiler/deSugar/DsExpr.lhs
@@ -32,8 +32,7 @@ import DsUtils		( mkAppDs, mkConDs, mkPrimDs, dsExprToAtom,
 			)
 import Match		( matchWrapper )
 
-import CoreUnfold	( UnfoldingDetails(..), UnfoldingGuidance(..),
-			  FormSummary )
+import CoreUnfold	( Unfolding )
 import CoreUtils	( coreExprType, substCoreExpr, argToExpr,
 			  mkCoreIfThenElse, unTagBinders )
 import CostCentre	( mkUserCC )
@@ -585,18 +584,20 @@ dsApp (TyApp expr tys) args
 
 -- we might should look out for SectionLs, etc., here, but we don't
 
-dsApp (HsVar v) args
-  = lookupEnvDs v	`thenDs` \ maybe_expr ->
+dsApp (HsVar v) args = mkAppDs (Var v) args
+
+{-	No need to do unfolding in desugarer now
+   = lookupEnvDs v	`thenDs` \ maybe_expr ->
     case maybe_expr of
       Just expr -> mkAppDs expr args
 
       Nothing -> -- we're only saturating constructors and PrimOps
 	case getIdUnfolding v of
-	  GenForm _ the_unfolding EssentialUnfolding
+	  SimpleUnfolding _ the_unfolding EssentialUnfolding
 	    -> do_unfold nullTyVarEnv nullIdEnv (unTagBinders the_unfolding) args
 
 	  _ -> mkAppDs (Var v) args
-
+-}
 
 dsApp anything_else args
   = dsExpr anything_else	`thenDs` \ core_expr ->
@@ -621,21 +622,21 @@ dsRbinds ((sel_id, rhs, pun_flag) : rbinds) continue_with
 \end{code}	
 
 \begin{code}
-do_unfold ty_env val_env (Lam (TyBinder tyvar) body) (TyArg ty : args)
-  = do_unfold (addOneToTyVarEnv ty_env tyvar ty) val_env body args
-
-do_unfold ty_env val_env (Lam (ValBinder binder) body) (arg@(VarArg expr) : args)
-  = dsExprToAtom arg  $ \ arg_atom ->
-    do_unfold ty_env
-	      (addOneToIdEnv val_env binder (argToExpr arg_atom))
-	      body args
-
-do_unfold ty_env val_env body args
-  = 	-- Clone the remaining part of the template
-    uniqSMtoDsM (substCoreExpr val_env ty_env body)	`thenDs` \ body' ->
-
-	-- Apply result to remaining arguments
-    mkAppDs body' args
+-- do_unfold ty_env val_env (Lam (TyBinder tyvar) body) (TyArg ty : args)
+--   = do_unfold (addOneToTyVarEnv ty_env tyvar ty) val_env body args
+-- 
+-- do_unfold ty_env val_env (Lam (ValBinder binder) body) (arg@(VarArg expr) : args)
+--   = dsExprToAtom arg  $ \ arg_atom ->
+--     do_unfold ty_env
+--      (addOneToIdEnv val_env binder (argToExpr arg_atom))
+--	      body args
+--
+-- do_unfold ty_env val_env body args
+--   = 	-- Clone the remaining part of the template
+--    uniqSMtoDsM (substCoreExpr val_env ty_env body)	`thenDs` \ body' ->
+--
+--	-- Apply result to remaining arguments
+--    mkAppDs body' args
 \end{code}
 
 Basically does the translation given in the Haskell~1.3 report:
diff --git a/ghc/compiler/deforest/DefExpr.lhs b/ghc/compiler/deforest/DefExpr.lhs
index ffeceba7b4..0c99fc4995 100644
--- a/ghc/compiler/deforest/DefExpr.lhs
+++ b/ghc/compiler/deforest/DefExpr.lhs
@@ -20,7 +20,7 @@
 >			  SYN_IE(SigmaType), Type
 >			)
 > import CmdLineOpts	( SwitchResult, switchIsOn )
-> import CoreUnfold	( UnfoldingDetails(..) )
+> import CoreUnfold	( Unfolding(..) )
 > import CoreUtils	( mkValLam, unTagBinders, coreExprType )
 > import Id		( applyTypeEnvToId, getIdUnfolding, isTopLevId, Id,
 > 			  isInstId_maybe
@@ -292,8 +292,8 @@ should an unfolding be required.
 >	  	then  no_unfold
 >
 >		else case (getIdUnfolding id) of
->			GenForm _ expr guidance ->
->			  panic "DefExpr:GenForm has changed a little; needs mod here"
+>			SimpleUnfolding _ expr guidance ->
+>			  panic "DefExpr:SimpleUnfolding has changed a little; needs mod here"
 >			  -- SLPJ March 95
 >
 >--???			  -- ToDo: too much overhead here.
diff --git a/ghc/compiler/hsSyn/HsPragmas.lhs b/ghc/compiler/hsSyn/HsPragmas.lhs
index 876ba1d234..fcbc6d9aa8 100644
--- a/ghc/compiler/hsSyn/HsPragmas.lhs
+++ b/ghc/compiler/hsSyn/HsPragmas.lhs
@@ -24,6 +24,7 @@ import HsTypes		( MonoType )
 
 -- others:
 import IdInfo
+import SpecEnv		( SpecEnv )
 import Outputable	( Outputable(..) )
 import Pretty
 \end{code}
diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs
index 50eed96fed..d6ccc129ee 100644
--- a/ghc/compiler/main/CmdLineOpts.lhs
+++ b/ghc/compiler/main/CmdLineOpts.lhs
@@ -96,6 +96,8 @@ import Argv
 
 CHK_Ubiq() -- debugging consistency check
 
+import CgCompInfo	-- Default values for some flags
+
 import Maybes		( assocMaybe, firstJust, maybeToBool )
 import Util		( startsWith, panic, panic#, assertPanic )
 \end{code}
@@ -193,6 +195,7 @@ data SimplifierSwitch
   | MaxSimplifierIterations Int
 
   | SimplUnfoldingUseThreshold      Int -- per-simplification variants
+  | SimplUnfoldingConDiscount       Int
   | SimplUnfoldingCreationThreshold Int
 
   | KeepSpecPragmaIds	    -- We normally *toss* Ids we can do without
@@ -337,7 +340,7 @@ classifyOpts = sep argv [] [] -- accumulators...
 	  ',' : _	-> IGNORE_ARG() -- it is for the parser
 
 	  "-fsimplify"  -> -- gather up SimplifierSwitches specially...
-			   simpl_sep opts [] core_td stg_td
+			   simpl_sep opts defaultSimplSwitches core_td stg_td
 
 	  "-fcalc-inlinings1"-> CORE_TD(CoreDoCalcInlinings1)
 	  "-fcalc-inlinings2"-> CORE_TD(CoreDoCalcInlinings2)
@@ -380,8 +383,7 @@ classifyOpts = sep argv [] [] -- accumulators...
 
     simpl_sep (opt1:opts) simpl_sw core_td stg_td
       = case (_UNPK_ opt1) of
-	  "(" -> ASSERT (null simpl_sw)
-		 simpl_sep opts [] core_td stg_td
+	  "(" -> simpl_sep opts simpl_sw core_td stg_td
 	  ")" -> let
 		    this_simpl = CoreDoSimplify (isAmongSimpl simpl_sw)
 		 in
@@ -418,15 +420,19 @@ classifyOpts = sep argv [] [] -- accumulators...
 	  o | starts_with_msi  -> SIMPL_SW(MaxSimplifierIterations (read after_msi))
 	    | starts_with_suut -> SIMPL_SW(SimplUnfoldingUseThreshold (read after_suut))
 	    | starts_with_suct -> SIMPL_SW(SimplUnfoldingCreationThreshold (read after_suct))
+	    | starts_with_sucd -> SIMPL_SW(SimplUnfoldingConDiscount (read after_sucd))
 	   where
 	    maybe_suut		= startsWith "-fsimpl-uf-use-threshold"      o
 	    maybe_suct		= startsWith "-fsimpl-uf-creation-threshold" o
+	    maybe_sucd		= startsWith "-fsimpl-uf-con-discount" o
 	    maybe_msi		= startsWith "-fmax-simplifier-iterations"   o
 	    starts_with_suut	= maybeToBool maybe_suut
 	    starts_with_suct	= maybeToBool maybe_suct
+	    starts_with_sucd	= maybeToBool maybe_sucd
 	    starts_with_msi	= maybeToBool maybe_msi
 	    (Just after_suut)	= maybe_suut
 	    (Just after_suct)	= maybe_suct
+	    (Just after_sucd)	= maybe_sucd
 	    (Just after_msi)	= maybe_msi
 
 	  _ -> -- NB: the driver is really supposed to handle bad options
@@ -470,13 +476,14 @@ tagOf_SimplSwitch EssentialUnfoldingsOnly	= ILIT(19)
 tagOf_SimplSwitch ShowSimplifierProgress	= ILIT(20)
 tagOf_SimplSwitch (MaxSimplifierIterations _)	= ILIT(21)
 tagOf_SimplSwitch (SimplUnfoldingUseThreshold _)      = ILIT(22)
-tagOf_SimplSwitch (SimplUnfoldingCreationThreshold _) = ILIT(23)
-tagOf_SimplSwitch KeepSpecPragmaIds		= ILIT(24)
-tagOf_SimplSwitch KeepUnusedBindings		= ILIT(25)
-tagOf_SimplSwitch SimplNoLetFromCase		= ILIT(26)
-tagOf_SimplSwitch SimplNoLetFromApp		= ILIT(27)
-tagOf_SimplSwitch SimplNoLetFromStrictLet	= ILIT(28)
-tagOf_SimplSwitch SimplDontFoldBackAppend       = ILIT(29)
+tagOf_SimplSwitch (SimplUnfoldingConDiscount _)       = ILIT(23)
+tagOf_SimplSwitch (SimplUnfoldingCreationThreshold _) = ILIT(24)
+tagOf_SimplSwitch KeepSpecPragmaIds		= ILIT(25)
+tagOf_SimplSwitch KeepUnusedBindings		= ILIT(26)
+tagOf_SimplSwitch SimplNoLetFromCase		= ILIT(27)
+tagOf_SimplSwitch SimplNoLetFromApp		= ILIT(28)
+tagOf_SimplSwitch SimplNoLetFromStrictLet	= ILIT(29)
+tagOf_SimplSwitch SimplDontFoldBackAppend       = ILIT(30)
 -- If you add anything here, be sure to change lAST_SIMPL_SWITCH_TAG, too!
 
 tagOf_SimplSwitch _ = panic# "tagOf_SimplSwitch"
@@ -504,9 +511,12 @@ lAST_SIMPL_SWITCH_TAG = IBOX(tagOf_SimplSwitch SimplDontFoldBackAppend)
 
 isAmongSimpl :: [SimplifierSwitch] -> SimplifierSwitch -> SwitchResult
 
-isAmongSimpl on_switches
+isAmongSimpl on_switches		-- Switches mentioned later occur *earlier*
+					-- in the list; defaults right at the end.
   = let
 	tidied_on_switches = foldl rm_dups [] on_switches
+		-- The fold*l* ensures that we keep the latest switches;
+		-- ie the ones that occur earliest in the list.
 
 	sw_tbl :: Array Int SwitchResult
 
@@ -527,12 +537,12 @@ isAmongSimpl on_switches
   where
     mk_assoc_elem k@(MaxSimplifierIterations lvl)       = IBOX(tagOf_SimplSwitch k) SET_TO SwInt lvl
     mk_assoc_elem k@(SimplUnfoldingUseThreshold      i) = IBOX(tagOf_SimplSwitch k) SET_TO SwInt i
+    mk_assoc_elem k@(SimplUnfoldingConDiscount       i) = IBOX(tagOf_SimplSwitch k) SET_TO SwInt i
     mk_assoc_elem k@(SimplUnfoldingCreationThreshold i) = IBOX(tagOf_SimplSwitch k) SET_TO SwInt i
 
     mk_assoc_elem k = IBOX(tagOf_SimplSwitch k) SET_TO SwBool   True -- I'm here, Mom!
 
     -- cannot have duplicates if we are going to use the array thing
-
     rm_dups switches_so_far switch
       = if switch `is_elem` switches_so_far
     	then switches_so_far
@@ -543,6 +553,16 @@ isAmongSimpl on_switches
 			    || sw `is_elem` ss
 \end{code}
 
+Default settings for simplifier switches
+
+\begin{code}
+defaultSimplSwitches = [SimplUnfoldingCreationThreshold uNFOLDING_CREATION_THRESHOLD,
+			SimplUnfoldingUseThreshold	uNFOLDING_USE_THRESHOLD,
+			SimplUnfoldingConDiscount	uNFOLDING_CON_DISCOUNT_WEIGHT,
+			MaxSimplifierIterations		1
+		       ]
+\end{code}
+
 %************************************************************************
 %*									*
 \subsection{Misc functions for command-line options}
diff --git a/ghc/compiler/main/Main.lhs b/ghc/compiler/main/Main.lhs
index 54a6783429..0db5364910 100644
--- a/ghc/compiler/main/Main.lhs
+++ b/ghc/compiler/main/Main.lhs
@@ -28,6 +28,7 @@ import AsmCodeGen	( dumpRealAsm, writeRealAsm )
 
 import AbsCSyn		( absCNop, AbstractC )
 import AbsCUtils	( flattenAbsC )
+import CoreUnfold	( Unfolding )
 import Bag		( emptyBag, isEmptyBag )
 import CmdLineOpts
 import ErrUtils		( pprBagOfErrors, ghcExit )
diff --git a/ghc/compiler/prelude/PrelInfo.lhs b/ghc/compiler/prelude/PrelInfo.lhs
index f659a9b7b9..c62c6fd53a 100644
--- a/ghc/compiler/prelude/PrelInfo.lhs
+++ b/ghc/compiler/prelude/PrelInfo.lhs
@@ -141,6 +141,19 @@ g_tycons
 g_con_tycons
   = listTyCon : mkTupleTyCon 0 : [mkTupleTyCon i | i <- [2..37] ]
 
+min_nonprim_tycon_list 	-- used w/ HideMostBuiltinNames
+  = [ boolTyCon
+    , charTyCon
+    , intTyCon
+    , floatTyCon
+    , doubleTyCon
+    , integerTyCon
+    , liftTyCon
+    , return2GMPsTyCon	-- ADR asked for these last two (WDP 94/11)
+    , returnIntAndGMPTyCon
+    ]
+
+
 data_tycons
   = [ addrTyCon
     , boolTyCon
diff --git a/ghc/compiler/prelude/PrelLoop.lhi b/ghc/compiler/prelude/PrelLoop.lhi
index 5f6b5e9177..acf9a4eae5 100644
--- a/ghc/compiler/prelude/PrelLoop.lhi
+++ b/ghc/compiler/prelude/PrelLoop.lhi
@@ -6,7 +6,7 @@ interface PrelLoop where
 import PreludePS	( _PackedString )
 
 import Class		( GenClass )
-import CoreUnfold	( mkMagicUnfolding, UnfoldingDetails )
+import CoreUnfold	( mkMagicUnfolding, Unfolding )
 import IdUtils		( primOpNameInfo )
 import Name		( Name, OrigName, mkPrimitiveName, mkWiredInName, ExportFlag )
 import PrimOp		( PrimOp )
@@ -16,7 +16,7 @@ import TyVar		( GenTyVar )
 import Unique		( Unique )
 import Usage		( GenUsage )
 
-mkMagicUnfolding :: Unique -> UnfoldingDetails
+mkMagicUnfolding :: Unique -> Unfolding
 mkPrimitiveName :: Unique -> OrigName -> Name
 mkWiredInName :: Unique -> OrigName -> ExportFlag -> Name
 mkSigmaTy :: [a] -> [(GenClass (GenTyVar (GenUsage Unique)) Unique, GenType a b)] -> GenType a b -> GenType a b
diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs
index 7598489424..05d9e5afb2 100644
--- a/ghc/compiler/rename/RnNames.lhs
+++ b/ghc/compiler/rename/RnNames.lhs
@@ -121,7 +121,7 @@ getGlobalNames iface_cache info us
 *********************************************************
 
 \begin{code}
-getSourceNames ::
+getSourceNames ::			-- Collects global *binders* (not uses)
 	   [RdrNameTyDecl]
 	-> [RdrNameClassDecl]
 	-> RdrNameHsBinds
diff --git a/ghc/compiler/simplCore/BinderInfo.lhs b/ghc/compiler/simplCore/BinderInfo.lhs
index 82e024d93b..43aa0bd7dc 100644
--- a/ghc/compiler/simplCore/BinderInfo.lhs
+++ b/ghc/compiler/simplCore/BinderInfo.lhs
@@ -14,11 +14,11 @@ module BinderInfo (
 	BinderInfo(..),
 	FunOrArg, DuplicationDanger, InsideSCC,  -- NB: all abstract (yay!)
 
-	inlineUnconditionally, oneTextualOcc, oneSafeOcc,
+	inlineUnconditionally, okToInline,
 
-	addBinderInfo, orBinderInfo,
+	addBinderInfo, orBinderInfo, 
 
-	argOccurrence, funOccurrence,
+	argOccurrence, funOccurrence, dangerousArgOcc, noBinderInfo,
 	markMany, markDangerousToDup, markInsideSCC,
 	getBinderInfoArity,
 	setBinderInfoArityToZero,
@@ -28,6 +28,7 @@ module BinderInfo (
 
 IMP_Ubiq(){-uitous-}
 
+import CoreUnfold	( FormSummary(..) )
 import Pretty
 import Util		( panic )
 \end{code}
@@ -95,30 +96,43 @@ data DuplicationDanger
 data InsideSCC
   = InsideSCC	    -- Inside an SCC; so be careful when substituting.
   | NotInsideSCC    -- It's ok.
+
+noBinderInfo = ManyOcc 0	-- A non-committal value
 \end{code}
 
 
 Predicates
 ~~~~~~~~~~
 
-@oneTextualOcc@ checks for one occurrence, in any position.
-The occurrence may be inside a lambda, that's all right.
-
 \begin{code}
-oneTextualOcc :: Bool -> BinderInfo -> Bool
-
-oneTextualOcc ok_to_dup (OneOcc _ _ _ n_alts _) = n_alts <= 1 || ok_to_dup
-oneTextualOcc _         other		        = False
-\end{code}
-
-@safeSingleOcc@ detects single occurences of values that are safe to
-inline, {\em including} ones in an argument position.
+okToInline
+	:: FormSummary	-- What the thing to be inlined is like
+	-> BinderInfo 	-- How the thing to be inlined occurs
+	-> Bool		-- True => it's small enough to inline
+	-> Bool		-- True => yes, inline it
+
+-- Always inline bottoms
+okToInline BottomForm occ_info small_enough
+  = True	-- Unless one of the type args is unboxed??
+		-- This used to be checked for, but I can't
+		-- see why so I've left it out.
+
+-- Non-WHNFs can be inlined if they occur once, or are small
+okToInline OtherForm (OneOcc _ _ _ n_alts _) small_enough | n_alts <= 1 = True
+okToInline OtherForm any_occ 		     small_enough 		= small_enough
+
+-- A WHNF can be inlined if it doesn't occur inside a lambda,
+-- and occurs exactly once or 
+--     occurs once in each branch of a case and is small
+okToInline form (OneOcc _ NoDupDanger _ n_alts _) small_enough 
+  = is_whnf_form form && 
+    (n_alts <= 1 || small_enough)
+  where
+    is_whnf_form VarForm   = True
+    is_whnf_form ValueForm = True
+    is_whnf_form other     = False
 
-\begin{code}
-oneSafeOcc :: Bool -> BinderInfo -> Bool
-oneSafeOcc ok_to_dup (OneOcc _ NoDupDanger NotInsideSCC n_alts _)
-						     = n_alts <= 1 || ok_to_dup
-oneSafeOcc _         other			     = False
+okToInline form any_occ small_enough = False
 \end{code}
 
 @inlineUnconditionally@ decides whether a let-bound thing can
@@ -166,6 +180,8 @@ markDangerousToDup (OneOcc posn _ in_scc n_alts ar)
   = OneOcc posn DupDanger in_scc n_alts ar
 markDangerousToDup other = other
 
+dangerousArgOcc = OneOcc ArgOcc DupDanger NotInsideSCC 1 0
+
 markInsideSCC (OneOcc posn dup_danger _ n_alts ar)
   = OneOcc posn dup_danger InsideSCC n_alts ar
 markInsideSCC other = other
diff --git a/ghc/compiler/simplCore/ConFold.lhs b/ghc/compiler/simplCore/ConFold.lhs
index 1b4c5ffeaa..43692600cf 100644
--- a/ghc/compiler/simplCore/ConFold.lhs
+++ b/ghc/compiler/simplCore/ConFold.lhs
@@ -15,7 +15,7 @@ module ConFold	( completePrim ) where
 IMP_Ubiq(){-uitous-}
 
 import CoreSyn
-import CoreUnfold	( whnfDetails, UnfoldingDetails(..), FormSummary(..) )
+import CoreUnfold	( Unfolding(..), SimpleUnfolding )
 import Id		( idType )
 import Literal		( mkMachInt, mkMachWord, Literal(..) )
 import MagicUFs		( MagicUnfoldingFun )
@@ -95,10 +95,8 @@ completePrim env SeqOp [TyArg ty, LitArg lit]
   = returnSmpl (Lit (mkMachInt 1))
 
 completePrim env op@SeqOp args@[TyArg ty, VarArg var]
-  | whnfDetails (lookupUnfolding env var)
-  = returnSmpl (Lit (mkMachInt 1))
-  | otherwise
-  = returnSmpl (Prim op args)
+  | isEvaluated (lookupRhsInfo env var) = returnSmpl (Lit (mkMachInt 1))  -- var is eval'd
+  | otherwise				= returnSmpl (Prim op args)	  -- var not eval'd
 \end{code}
 
 \begin{code}
diff --git a/ghc/compiler/simplCore/LiberateCase.lhs b/ghc/compiler/simplCore/LiberateCase.lhs
index 04aaa58ed4..a67c6a6f55 100644
--- a/ghc/compiler/simplCore/LiberateCase.lhs
+++ b/ghc/compiler/simplCore/LiberateCase.lhs
@@ -180,11 +180,12 @@ libCaseBind env (Rec pairs)
 	-- to think that something is top-level when it isn't.
 
     rhs_small_enough rhs
-      = case (calcUnfoldingGuidance True{-sccs OK-} lIBERATE_BOMB_SIZE rhs) of
+      = case (calcUnfoldingGuidance True{-sccs OK-} lIBERATE_BOMB_SIZE cON_DISCOUNT rhs) of
 	  UnfoldNever -> False
 	  _ 	      -> True	-- we didn't BOMB, so it must be OK
 
     lIBERATE_BOMB_SIZE = bombOutSize env
+    cON_DISCOUNT = error "libCaseBind"
 \end{code}
 
 
diff --git a/ghc/compiler/simplCore/MagicUFs.lhs b/ghc/compiler/simplCore/MagicUFs.lhs
index 1bef7159e1..79f659ecfa 100644
--- a/ghc/compiler/simplCore/MagicUFs.lhs
+++ b/ghc/compiler/simplCore/MagicUFs.lhs
@@ -37,7 +37,7 @@ data MagicUnfoldingFun
 				-- (note: we can get simplifier switches
 				-- from the SimplEnv)
 	-> [CoreArg]       -- arguments
-	-> SmplM (Maybe CoreExpr))
+	-> Maybe (SmplM CoreExpr))
 				-- Just result, or Nothing
 \end{code}
 
@@ -58,7 +58,7 @@ applyMagicUnfoldingFun
 	:: MagicUnfoldingFun
 	-> SimplEnv
 	-> [CoreArg]
-	-> SmplM (Maybe CoreExpr)
+	-> Maybe (SmplM CoreExpr)
 
 applyMagicUnfoldingFun (MUF fun) env args = fun env args
 \end{code}
@@ -94,44 +94,45 @@ magic_UFs_table
 
 build_fun :: SimplEnv
 	  -> [CoreArg]
-	  -> SmplM (Maybe CoreExpr)
+	  -> Maybe (SmplM CoreExpr)
 build_fun env [TypeArg ty,ValArg (VarArg e)]
-	| switchIsSet env SimplDoInlineFoldrBuild =
-	let
-		tyL     = mkListTy ty
-		ourCons = CoTyApp (Var consDataCon) ty
-		ourNil  = CoTyApp (Var nilDataCon) ty
-	in
-	newIds  [ mkFunTys [ty, tyL] tyL, tyL ]	`thenSmpl` \ [c,n] ->
-	returnSmpl(Just (Let (NonRec c ourCons)
-			(Let (NonRec n ourNil)
-			 (App (App (CoTyApp (Var e) tyL) (VarArg c)) (VarArg n)))))
+  | switchIsSet env SimplDoInlineFoldrBuild
+  = Just result
+  where
+    tyL     = mkListTy ty
+    ourCons = CoTyApp (Var consDataCon) ty
+    ourNil  = CoTyApp (Var nilDataCon) ty
+
+    result = newIds  [ mkFunTys [ty, tyL] tyL, tyL ]	`thenSmpl` \ [c,n] ->
+	     returnSmpl(Let (NonRec c ourCons)
+		       (Let (NonRec n ourNil)
+		       (App (App (CoTyApp (Var e) tyL) (VarArg c)) (VarArg n)))
+
 -- ToDo: add `build' without an argument instance.
 -- This is strange, because of g's type.
-build_fun env _ =
-	ASSERT (not (switchIsSet env SimplDoInlineFoldrBuild))
-	returnSmpl Nothing
+build_fun env _ = ASSERT (not (switchIsSet env SimplDoInlineFoldrBuild))
+	  	  Nothing
 \end{code}
 
 \begin{code}
 augment_fun :: SimplEnv
 	  -> [CoreArg]
-	  -> SmplM (Maybe CoreExpr)
+	  -> Maybe (SmplM CoreExpr)
 
 augment_fun env [TypeArg ty,ValArg (VarArg e),ValArg nil]
-	| switchIsSet env SimplDoInlineFoldrBuild =
-	let
-		tyL     = mkListTy ty
-		ourCons = CoTyApp (Var consDataCon) ty
-	in
-	newId  (mkFunTys [ty, tyL] tyL)    `thenSmpl` \ c ->
-	returnSmpl (Just (Let (NonRec c ourCons)
-			 (App (App (CoTyApp (Var e) tyL) (VarArg c)) nil)))
+ | switchIsSet env SimplDoInlineFoldrBuild
+ = Just result
+ where
+   tyL     = mkListTy ty
+   ourCons = CoTyApp (Var consDataCon) ty
+   result = newId  (mkFunTys [ty, tyL] tyL)    `thenSmpl` \ c ->
+	    returnSmpl (Let (NonRec c ourCons)
+		       (App (App (CoTyApp (Var e) tyL) (VarArg c)) nil))
 -- ToDo: add `build' without an argument instance.
 -- This is strange, because of g's type.
-augment_fun env _ =
-	ASSERT (not (switchIsSet env SimplDoInlineFoldrBuild))
-	returnSmpl Nothing
+
+augment_fun env _ = ASSERT (not (switchIsSet env SimplDoInlineFoldrBuild))
+		    Nothing
 \end{code}
 
 Now foldr, the way we consume lists.
@@ -139,49 +140,53 @@ Now foldr, the way we consume lists.
 \begin{code}
 foldr_fun :: SimplEnv
 	  -> [CoreArg]
-	  -> SmplM (Maybe CoreExpr)
+	  -> Maybe (SmplM CoreExpr)
 
 foldr_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:ValArg arg_z:rest_args)
   | do_fb_red && isConsFun env arg_k && isNilForm env arg_z
-  =     -- foldr (:) [] ==> id
+        -- foldr (:) [] ==> id
 	-- this transformation is *always* benificial
 	-- cf.  foldr (:) [] (build g) == g (:) []
 	-- with foldr (:) [] (build g) == build g
 	-- after unfolding build, they are the same thing.
-     tick Foldr_Cons_Nil		`thenSmpl_`
-     newId (mkListTy ty1) 		`thenSmpl` \ x ->
-     returnSmpl({-trace "foldr (:) []"-} (Just (mkGenApp (Lam x (Var x)) rest_args)))
+  = Just (tick Foldr_Cons_Nil		`thenSmpl_`
+	  newId (mkListTy ty1) 		`thenSmpl` \ x ->
+          returnSmpl({-trace "foldr (:) []"-} (mkGenApp (Lam x (Var x)) rest_args))
+    )
  where
    do_fb_red		= switchIsSet env SimplDoFoldrBuild
 
 foldr_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:ValArg arg_z:ValArg arg_list:rest_args)
  | do_fb_red && isNilForm env arg_list
-  =     -- foldr f z [] = z
+        -- foldr f z [] = z
 	-- again another short cut, helps with unroling of constant lists
-    tick Foldr_Nil	`thenSmpl_`
-    returnSmpl (Just (argToExpr arg_z))
+ = Just (tick Foldr_Nil	`thenSmpl_`
+	 returnSmpl (argToExpr arg_z)
+   )
 
   | do_fb_red && arg_list_isBuildForm
-  =     -- foldr k z (build g) ==> g k z
+        -- foldr k z (build g) ==> g k z
 	-- this next line *is* the foldr/build rule proper.
-    tick FoldrBuild	`thenSmpl_`
-    returnSmpl (Just (mkGenApp (Var g) (TypeArg ty2:ValArg arg_k:ValArg arg_z:rest_args)))
+  = Just (tick FoldrBuild	`thenSmpl_`
+	  returnSmpl (mkGenApp (Var g) (TypeArg ty2:ValArg arg_k:ValArg arg_z:rest_args))
+    )
 
   | do_fb_red && arg_list_isAugmentForm
-  =     -- foldr k z (augment g h) ==> let v = foldr k z h in g k v
+        -- foldr k z (augment g h) ==> let v = foldr k z h in g k v
 	-- this next line *is* the foldr/augment rule proper.
-    tick FoldrAugment	`thenSmpl_`
-    newId ty2				`thenSmpl` \ v ->
-    returnSmpl (Just
-		(Let (NonRec v (mkGenApp (Var foldrId)
+  = Just (tick FoldrAugment	`thenSmpl_`
+	  newId ty2				`thenSmpl` \ v ->
+	  returnSmpl (
+		Let (NonRec v (mkGenApp (Var foldrId)
 					[TypeArg ty1,TypeArg ty2,
 					 ValArg arg_k,
 					 ValArg arg_z,
 					 ValArg h]))
-		(mkGenApp (Var g') (TypeArg ty2:ValArg arg_k:ValArg (VarArg v):rest_args))))
+		(mkGenApp (Var g') (TypeArg ty2:ValArg arg_k:ValArg (VarArg v):rest_args)))
+    )
 
  | do_fb_red && arg_list_isListForm
- =      -- foldr k z (a:b:c:rest) =
+        -- foldr k z (a:b:c:rest) =
 	--	(\ f -> f a (f b (f c (foldr f z rest)))) k rest_args
 	-- NB: 'k' is used just one by foldr, but 'f' is used many
 	-- times inside the list structure. This means that
@@ -196,45 +201,46 @@ foldr_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:ValArg arg_z:ValArg arg_list
 	--	    ele_3 = f b ele_2
 	--	in f a ele_3
 	--
-  tick Foldr_List	`thenSmpl_`
-  newIds (
+  = Just (tick Foldr_List	`thenSmpl_`
+	  newIds (
 		mkFunTys [ty1, ty2] ty2 :
 		nOfThem (length the_list) ty2
-	)			`thenSmpl` \ (f_id:ele_id1:ele_ids) ->
-  let
-	fst_bind = NonRec
+	  )			`thenSmpl` \ (f_id:ele_id1:ele_ids) ->
+	  let
+	    fst_bind = NonRec
 			ele_id1
 			(mkGenApp (Var foldrId)
 				[TypeArg ty1,TypeArg ty2,
 				 ValArg (VarArg f_id),
 				 ValArg arg_z,
 				 ValArg the_tl])
-	rest_binds = zipWith3Equal "Foldr:rest_binds"
+	    rest_binds = zipWith3Equal "Foldr:rest_binds"
 			 (\ e v e' -> NonRec e (mkRhs v e'))
 			 ele_ids
 			 (reverse (tail the_list))
 			 (init (ele_id1:ele_ids))
-	mkRhs v e = App (App (Var f_id) v) (VarArg e)
-	core_list = foldr
+	    mkRhs v e = App (App (Var f_id) v) (VarArg e)
+	    core_list = foldr
 			Let
 			(mkRhs (head the_list) (last (ele_id1:ele_ids)))
 			(fst_bind:rest_binds)
-  in
- 	returnSmpl (Just (mkGenApp (Lam f_id core_list)
-				      (ValArg arg_k:rest_args)))
+          in
+ 	  returnSmpl (mkGenApp (Lam f_id core_list) (ValArg arg_k:rest_args))
+    )
 
 
 	--
 
  | do_fb_red && arg_list_isStringForm	-- ok, its a string!
 	-- foldr f z "foo" => unpackFoldrPS__ f z "foo"#
-   = tick Str_FoldrStr				`thenSmpl_`
-     returnSmpl (Just (mkGenApp (Var unpackCStringFoldrId)
+ = Just (tick Str_FoldrStr				`thenSmpl_`
+	 returnSmpl (mkGenApp (Var unpackCStringFoldrId)
 				(TypeArg ty2:
 				 ValArg (LitArg (MachStr str_val)):
 				 ValArg arg_k:
 				 ValArg arg_z:
-				 rest_args)))
+				 rest_args))
+   )
  where
    do_fb_red		= switchIsSet env SimplDoFoldrBuild
 
@@ -261,19 +267,21 @@ foldr_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:ValArg arg_z:ValArg arg_list
 
 foldr_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:rest_args)
   | doing_inlining && isConsFun env arg_k && not dont_fold_back_append
-  =    -- foldr (:) z xs = xs ++ z
-     tick Foldr_Cons	`thenSmpl_`
-     newIds [ty2,mkListTy ty1] `thenSmpl` \ [z,x] ->
-     returnSmpl (Just (mkGenApp
+       -- foldr (:) z xs = xs ++ z
+  = Just (tick Foldr_Cons	`thenSmpl_`
+	   newIds [ty2,mkListTy ty1] `thenSmpl` \ [z,x] ->
+	   returnSmpl (mkGenApp
 			(Lam z (Lam x (mkGenApp
 					(Var appendId) [
 						TypeArg ty1,
 						ValArg (VarArg x),
-						ValArg (VarArg z)])))
+						ValArg (VarArg z)]))
 			rest_args))
+    )
+
   | doing_inlining && (isInterestingArg env arg_k
 		       || isConsFun env arg_k)
-  =   -- foldr k args =
+      -- foldr k args =
       --        (\ f z xs ->
       --          letrec
       --             h x = case x of
@@ -283,7 +291,7 @@ foldr_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:rest_args)
       --             h xs) k args
       --
 --     tick FoldrInline		`thenSmpl_`
-     newIds [
+  = Just (newIds [
 		ty1,                    -- a :: t1
 		mkListTy ty1,           -- b :: [t1]
 		ty2,                    -- v :: t2
@@ -306,21 +314,23 @@ foldr_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:rest_args)
 						  (VarArg a))
 						    (VarArg v))
 	   in
-	     returnSmpl (Just
-		     (mkGenApp
+	     returnSmpl (
+		     mkGenApp
 			 (Lam f (Lam z (Lam xs
 			  (Let (Rec [(h,h_rhs)])
 				 (App (Var h) (VarArg xs))))))
-		     (ValArg arg_k:rest_args)))
+		     (ValArg arg_k:rest_args))
+    )
    where
-	doing_inlining = switchIsSet env SimplDoInlineFoldrBuild
-	dont_fold_back_append = switchIsSet env SimplDontFoldBackAppend
-foldr_fun _ _ = returnSmpl Nothing
+     doing_inlining = switchIsSet env SimplDoInlineFoldrBuild
+     dont_fold_back_append = switchIsSet env SimplDontFoldBackAppend
+
+foldr_fun _ _ = Nothing
 
 isConsFun :: SimplEnv -> CoreArg -> Bool
 isConsFun env (VarArg v)
   = case lookupUnfolding env v of
-	GenForm _ (Lam (x,_) (Lam (y,_) (Con con tys [VarArg x',VarArg y']))) _
+	SimpleUnfolding _ (Lam (x,_) (Lam (y,_) (Con con tys [VarArg x',VarArg y']))) _
 	  | con == consDataCon && x==x' && y==y'
 	  -> ASSERT ( length tys == 1 ) True
 	_ -> False
@@ -329,19 +339,19 @@ isConsFun env _ = False
 isNilForm :: SimplEnv -> CoreArg -> Bool
 isNilForm env (VarArg v)
   = case lookupUnfolding env v of
-	GenForm _ (CoTyApp (Var id) _) _ | id == nilDataCon -> True
-	GenForm _ (Lit (NoRepStr s))   _ | _NULL_ s	      -> True
+	SimpleUnfolding _ (CoTyApp (Var id) _) _ | id == nilDataCon -> True
+	SimpleUnfolding _ (Lit (NoRepStr s))   _ | _NULL_ s	      -> True
 	_ 						      -> False
 isNilForm env _ = False
 
 getBuildForm :: SimplEnv -> CoreArg -> Maybe Id
 getBuildForm env (VarArg v)
   = case lookupUnfolding env v of
-	GenForm False _ _ _ -> Nothing
+	SimpleUnfolding False _ _ _ -> Nothing
 					-- not allowed to inline :-(
-	GenForm _ (App (CoTyApp (Var bld) _) (VarArg g)) _
+	SimpleUnfolding _ (App (CoTyApp (Var bld) _) (VarArg g)) _
 	  | bld == buildId -> Just g
-	GenForm _ (App (App (CoTyApp (Var bld) _)
+	SimpleUnfolding _ (App (App (CoTyApp (Var bld) _)
 					(VarArg g)) h) _
 	  | bld == augmentId && isNilForm env h  -> Just g
 	_ -> Nothing
@@ -352,9 +362,9 @@ getBuildForm env _ = Nothing
 getAugmentForm :: SimplEnv -> CoreArg -> Maybe (Id,CoreArg)
 getAugmentForm env (VarArg v)
   = case lookupUnfolding env v of
-	GenForm False _ _ _ -> Nothing
+	SimpleUnfolding False _ _ _ -> Nothing
 				-- not allowed to inline :-(
-	GenForm _ (App (App (CoTyApp (Var bld) _)
+	SimpleUnfolding _ (App (App (CoTyApp (Var bld) _)
 						(VarArg g)) h) _
 	  | bld == augmentId -> Just (g,h)
 	_ -> Nothing
@@ -368,8 +378,8 @@ getStringForm env _ = Nothing
 getAppendForm :: SimplEnv -> CoreArg -> Maybe (GenCoreAtom Id,GenCoreAtom Id)
 getAppendForm env (VarArg v) =
     case lookupUnfolding env v of
-	GenForm False _ _ _ -> Nothing	-- not allowed to inline :-(
-	GenForm _ (App (App (App (CoTyApp (CoTyApp (Var fld) _) _) con) ys) xs) _
+	SimpleUnfolding False _ _ _ -> Nothing	-- not allowed to inline :-(
+	SimpleUnfolding _ (App (App (App (CoTyApp (CoTyApp (Var fld) _) _) con) ys) xs) _
 	  | fld == foldrId && isConsFun env con -> Just (xs,ys)
 	_ -> Nothing
 getAppendForm env _ = Nothing
@@ -386,7 +396,7 @@ getListForm
 	-> Maybe ([CoreArg],CoreArg)
 getListForm env (VarArg v)
   = case lookupUnfolding env v of
-       GenForm _ (Con id [ty_arg,head,tail]) _
+       SimpleUnfolding _ (Con id [ty_arg,head,tail]) _
 	  | id == consDataCon ->
 		case getListForm env tail of
  		   Nothing -> Just ([head],tail)
@@ -397,36 +407,37 @@ getListForm env _ = Nothing
 isInterestingArg :: SimplEnv -> CoreArg -> Bool
 isInterestingArg env (VarArg v)
   = case lookupUnfolding env v of
-       GenForm False _ _ UnfoldNever -> False
-       GenForm _ exp guide -> True
+       SimpleUnfolding False _ _ UnfoldNever -> False
+       SimpleUnfolding _ exp guide -> True
        _ -> False
 isInterestingArg env _ = False
 
 foldl_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:ValArg arg_z:ValArg arg_list:rest_args)
  | do_fb_red && isNilForm env arg_list
-  =     -- foldl f z [] = z
+        -- foldl f z [] = z
 	-- again another short cut, helps with unroling of constant lists
-    tick Foldl_Nil	`thenSmpl_`
-    returnSmpl (Just (argToExpr arg_z))
+ = Just (tick Foldl_Nil	`thenSmpl_`
+	 returnSmpl (argToExpr arg_z)
+   )
 
   | do_fb_red && arg_list_isBuildForm
-  =     -- foldl t1 t2 k z (build t3 g) ==>
+        -- foldl t1 t2 k z (build t3 g) ==>
 	--		   let c {- INLINE -} = \ b g' a -> g' (f a b)
 	--		       n {- INLINE -} = \ a -> a
 	--		   in g t1 c n z
 	-- this next line *is* the foldr/build rule proper.
-    tick FoldlBuild	`thenSmpl_`
+  = Just(tick FoldlBuild	`thenSmpl_`
 	-- c :: t2 -> (t1 -> t1) -> t1 -> t1
 	-- n :: t1 -> t1
-    newIds [
-	{- pre_c -}	mkFunTys [ty2, mkFunTys [ty1] ty1, ty1]  ty1,
-	{- pre_n -}	mkFunTys [ty1] ty1,
-	{- b -}		ty2,
-	{- g' -}	mkFunTys [ty1] ty1,
-	{- a -}		ty1,
-	{- a' -}	ty1,
-	{- t -}		ty1
-	]		`thenSmpl` \ [pre_c,
+         newIds [
+	  {- pre_c -}	mkFunTys [ty2, mkFunTys [ty1] ty1, ty1]  ty1,
+	  {- pre_n -}	mkFunTys [ty1] ty1,
+	  {- b -}	ty2,
+	  {- g' -}	mkFunTys [ty1] ty1,
+	  {- a -}	ty1,
+	  {- a' -}	ty1,
+	  {- t -}	ty1
+	  ]		`thenSmpl` \ [pre_c,
 				      pre_n,
 				      b,
 				      g',
@@ -434,39 +445,41 @@ foldl_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:ValArg arg_z:ValArg arg_list
 				      a',
 				      t] ->
 
-    let
-	c     = addIdUnfolding pre_c (iWantToBeINLINEd UnfoldAlways)
-	c_rhs = Lam b (Lam g' (Lam a
-		 (Let (NonRec t (App (App (argToExpr arg_k) (VarArg a)) (VarArg b)))
+        let
+	  c     = addIdUnfolding pre_c (iWantToBeINLINEd UnfoldAlways)
+	  c_rhs = Lam b (Lam g' (Lam a
+		  (Let (NonRec t (App (App (argToExpr arg_k) (VarArg a)) (VarArg b)))
 			 (App (Var g') (VarArg t)))))
-	n     = addIdUnfolding pre_n (iWantToBeINLINEd UnfoldAlways)
-	n_rhs = Lam a' (Var a')
-    in
-    returnSmpl (Just (Let (NonRec c c_rhs) (Let (NonRec n n_rhs)
-		  (mkGenApp (Var g)
-		      (TypeArg (mkFunTys [ty1] ty1):ValArg (VarArg c):ValArg (VarArg n)
-				:ValArg arg_z:rest_args)))))
+	  n     = addIdUnfolding pre_n (iWantToBeINLINEd UnfoldAlways)
+	  n_rhs = Lam a' (Var a')
+        in
+        returnSmpl (Let (NonRec c c_rhs) $
+		    Let (NonRec n n_rhs) $
+		    mkGenApp (Var g) 
+		    (TypeArg (mkFunTys [ty1] ty1):ValArg (VarArg c):ValArg (VarArg n)
+				:ValArg arg_z:rest_args))
+    )
 
   | do_fb_red && arg_list_isAugmentForm
-  =     -- foldl t1 t2 k z (augment t3 g h) ==>
+        -- foldl t1 t2 k z (augment t3 g h) ==>
 	--		   let c {- INLINE -} = \ b g' a -> g' (f a b)
 	--		       n {- INLINE -} = \ a -> a
 	--		       r {- INLINE -} = foldr t2 (t1 -> t1) c n h
 	--		   in g t1 c r z
 	-- this next line *is* the foldr/build rule proper.
-    tick FoldlAugment	`thenSmpl_`
+  = Just (tick FoldlAugment	`thenSmpl_`
 	-- c :: t2 -> (t1 -> t1) -> t1 -> t1
 	-- n :: t1 -> t1
-    newIds [
-	{- pre_c -}	mkFunTys [ty2, mkFunTys [ty1] ty1, ty1] ty1,
-	{- pre_n -}	mkFunTys [ty1] ty1,
-	{- pre_r -}	mkFunTys [ty1] ty1,
-	{- b -}		ty2,
-	{- g_ -}	mkFunTys [ty1] ty1,
-	{- a -}		ty1,
-	{- a' -}	ty1,
-	{- t -}		ty1
-	]		`thenSmpl` \ [pre_c,
+          newIds [
+	   {- pre_c -}	mkFunTys [ty2, mkFunTys [ty1] ty1, ty1] ty1,
+	   {- pre_n -}	mkFunTys [ty1] ty1,
+	   {- pre_r -}	mkFunTys [ty1] ty1,
+	   {- b -}	ty2,
+	   {- g_ -}	mkFunTys [ty1] ty1,
+	   {- a -}	ty1,
+	   {- a' -}	ty1,
+	   {- t -}	ty1
+	   ]		`thenSmpl` \ [pre_c,
 				      pre_n,
 				      pre_r,
 				      b,
@@ -475,29 +488,30 @@ foldl_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:ValArg arg_z:ValArg arg_list
 				      a',
 				      t] ->
 
-    let
-	c     = addIdUnfolding pre_c (iWantToBeINLINEd UnfoldAlways)
-	c_rhs = Lam b (Lam g_ (Lam a
-		 (Let (NonRec t (App (App (argToExpr arg_k) (VarArg a)) (VarArg b)))
+        let
+	  c     = addIdUnfolding pre_c (iWantToBeINLINEd UnfoldAlways)
+	  c_rhs = Lam b (Lam g_ (Lam a
+		  (Let (NonRec t (App (App (argToExpr arg_k) (VarArg a)) (VarArg b)))
 			 (App (Var g_) (VarArg t)))))
-	n     = addIdUnfolding pre_n (iWantToBeINLINEd UnfoldAlways)
-	n_rhs = Lam a' (Var a')
-	r     = addIdUnfolding pre_r (iWantToBeINLINEd UnfoldAlways)
-	r_rhs = mkGenApp (Var foldrId)
+	  n     = addIdUnfolding pre_n (iWantToBeINLINEd UnfoldAlways)
+	  n_rhs = Lam a' (Var a')
+	  r     = addIdUnfolding pre_r (iWantToBeINLINEd UnfoldAlways)
+	  r_rhs = mkGenApp (Var foldrId)
 					[TypeArg ty2,TypeArg (mkFunTys [ty1] ty1),
 					 ValArg (VarArg c),
 					 ValArg (VarArg n),
 					 ValArg h]
-    in
-    returnSmpl (Just (Let (NonRec c c_rhs)
-		     (Let (NonRec n n_rhs)
-		     (Let (NonRec r r_rhs)
-		  (mkGenApp (Var g')
+       in
+       returnSmpl (Let (NonRec c c_rhs) $
+		   Let (NonRec n n_rhs) $
+		   Let (NonRec r r_rhs) $
+		   mkGenApp (Var g')
 		      (TypeArg (mkFunTys [ty1] ty1):ValArg (VarArg c):ValArg (VarArg r)
-				:ValArg arg_z:rest_args))))))
+				:ValArg arg_z:rest_args))
+    )
 
  | do_fb_red && arg_list_isListForm
- =      -- foldl k z (a:b:c:rest) =
+        -- foldl k z (a:b:c:rest) =
 	--	(\ f -> foldl f (f (f (f z a) b) c) rest) k rest_args
 	-- NB: 'k' is used just one by foldr, but 'f' is used many
 	-- times inside the list structure. This means that
@@ -513,31 +527,32 @@ foldl_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:ValArg arg_z:ValArg arg_list
 	--	    ele_3 = f ele_2 c
 	--	in foldl f ele_3 rest
 	--
-  tick Foldl_List	`thenSmpl_`
-  newIds (
+  = Just (tick Foldl_List	`thenSmpl_`
+          newIds (
 		mkFunTys [ty1, ty2] ty1 :
 		nOfThem (length the_list) ty1
-	)			`thenSmpl` \ (f_id:ele_ids) ->
-  let
-	rest_binds = zipWith3Equal "foldl:rest_binds"
+	  )			`thenSmpl` \ (f_id:ele_ids) ->
+          let
+	    rest_binds = zipWith3Equal "foldl:rest_binds"
 			 (\ e v e' -> NonRec e (mkRhs v e'))
 			 ele_ids				-- :: [Id]
 			 the_list				-- :: [CoreArg]
 			 (init (arg_z:map VarArg ele_ids))	-- :: [CoreArg]
-	mkRhs v e = App (App (Var f_id) e) v
+	    mkRhs v e = App (App (Var f_id) e) v
 
-	last_bind = mkGenApp (Var foldlId)
+	    last_bind = mkGenApp (Var foldlId)
 				[TypeArg ty1,TypeArg ty2,
 				 ValArg (VarArg f_id),
 				 ValArg (VarArg (last ele_ids)),
 				 ValArg the_tl]
-	core_list = foldr
+	    core_list = foldr
 			Let
 			last_bind
 			rest_binds
-  in
- 	returnSmpl (Just (mkGenApp (Lam f_id core_list)
-				      (ValArg arg_k:rest_args)))
+	  in
+ 	  returnSmpl (mkGenApp (Lam f_id core_list)
+				      (ValArg arg_k:rest_args))
+    )
 
  where
    do_fb_red		= switchIsSet env SimplDoFoldrBuild
@@ -563,7 +578,7 @@ foldl_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:ValArg arg_z:ValArg arg_list
 foldl_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:rest_args)
   | doing_inlining && (isInterestingArg env arg_k
 		       || isConsFun env arg_k)
-  =   -- foldl k args =
+      -- foldl k args =
       --        (\ f z xs ->
       --          letrec
       --             h x r = case x of
@@ -572,6 +587,7 @@ foldl_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:rest_args)
       --          in
       --             h xs z) k args
       --
+  = Just (
 --     tick FoldrInline				`thenSmpl_`
      newIds [
 		ty2,                    -- a :: t1
@@ -598,17 +614,18 @@ foldl_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:rest_args)
 						  (VarArg b))
 						    (VarArg v))
 	   in
-	     returnSmpl (Just
+	     returnSmpl (
 		     (mkGenApp
 			 (Lam f (Lam z (Lam xs
 			  (Let (Rec [(h,h_rhs)])
 				 (App (App (Var h) (VarArg xs))
 							 (VarArg z))))))
-		     (ValArg arg_k:rest_args)))
+		     (ValArg arg_k:rest_args))
+   )
    where
 	doing_inlining = switchIsSet env SimplDoInlineFoldrBuild
 
-foldl_fun env _ = returnSmpl Nothing
+foldl_fun env _ =  Nothing
 \end{code}
 
 
@@ -618,17 +635,19 @@ foldl_fun env _ = returnSmpl Nothing
 --
 unpack_foldr_fun env [TypeArg ty,ValArg str,ValArg arg_k,ValArg arg_z]
    | switchIsSet env SimplDoFoldrBuild && isConsFun env arg_k
-   = tick Str_UnpackCons		`thenSmpl_`
-     returnSmpl (Just (mkGenApp (Var unpackCStringAppendId)
+   = Just (tick Str_UnpackCons		`thenSmpl_`
+           returnSmpl (mkGenApp (Var unpackCStringAppendId)
 				[ValArg str,
-				 ValArg arg_z]))
-unpack_foldr_fun env _ = returnSmpl Nothing
+				 ValArg arg_z])
+     )
+unpack_foldr_fun env _ =  Nothing
 
 unpack_append_fun env
 	[ValArg (LitArg (MachStr str_val)),ValArg arg_z]
    | switchIsSet env SimplDoFoldrBuild && isNilForm env arg_z
-   = tick Str_UnpackNil		`thenSmpl_`
-     returnSmpl (Just (Lit (NoRepStr str_val)))
-unpack_append_fun env _ = returnSmpl Nothing
+   = Just (tick Str_UnpackNil		`thenSmpl_`
+	   returnSmpl (Lit (NoRepStr str_val))
+     )
+unpack_append_fun env _ =  Nothing
 -}
 \end{code}
diff --git a/ghc/compiler/simplCore/OccurAnal.lhs b/ghc/compiler/simplCore/OccurAnal.lhs
index aed02576fa..4453c103c6 100644
--- a/ghc/compiler/simplCore/OccurAnal.lhs
+++ b/ghc/compiler/simplCore/OccurAnal.lhs
@@ -380,8 +380,27 @@ occAnal env (Var v)
   = (emptyDetails, Var v)
 
 occAnal env (Lit lit)	   = (emptyDetails, Lit lit)
-occAnal env (Con con args) = (occAnalArgs env args, Con con args)
 occAnal env (Prim op args) = (occAnalArgs env args, Prim op args)
+\end{code}
+
+We regard variables that occur as constructor arguments as "dangerousToDup":
+
+\begin{verbatim}
+module A where
+f x = let y = expensive x in 
+      let z = (True,y) in 
+      (case z of {(p,q)->q}, case z of {(p,q)->q})
+\end{verbatim}
+
+We feel free to duplicate the WHNF (True,y), but that means
+that y may be duplicated thereby.
+
+If we aren't careful we duplicate the (expensive x) call!
+Constructors are rather like lambdas in this way.
+
+\begin{code}
+occAnal env (Con con args) = (mapIdEnv markDangerousToDup (occAnalArgs env args), 
+			      Con con args)
 
 occAnal env (SCC cc body)
   = (mapIdEnv markInsideSCC usage, SCC cc body')
@@ -399,12 +418,21 @@ occAnal env (App fun arg)
     (fun_usage, fun') = occAnal    env fun
     arg_usage	      = occAnalArg env arg
 
-occAnal env (Lam (ValBinder binder) body)
+-- For value lambdas we do a special hack.  Consider
+-- 	(\x. \y. ...x...)
+-- If we did nothing, x is used inside the \y, so would be marked
+-- as dangerous to dup.  But in the common case where the abstraction
+-- is applied to two arguments this is over-pessimistic.
+-- So instead we don't take account of the \y when dealing with x's usage;
+-- instead, the simplifier is careful when partially applying lambdas
+
+occAnal env expr@(Lam (ValBinder binder) body)
   = (mapIdEnv markDangerousToDup final_usage,
-     Lam (ValBinder tagged_binder) body')
+     foldr ( \v b -> Lam (ValBinder v) b) body' tagged_binders)
   where
-    (body_usage, body') 	 = occAnal (env `addNewCand` binder) body
-    (final_usage, tagged_binder) = tagBinder body_usage binder
+    (binders,body)		  = collectValBinders expr
+    (body_usage, body') 	  = occAnal (env `addNewCands` binders) body
+    (final_usage, tagged_binders) = tagBinders body_usage binders
 
 -- ANDY: WE MUST THINK ABOUT THIS! (ToDo)
 occAnal env (Lam (TyBinder tyvar) body)
diff --git a/ghc/compiler/simplCore/SetLevels.lhs b/ghc/compiler/simplCore/SetLevels.lhs
index 08f4b1649c..ca79733201 100644
--- a/ghc/compiler/simplCore/SetLevels.lhs
+++ b/ghc/compiler/simplCore/SetLevels.lhs
@@ -26,7 +26,8 @@ IMP_Ubiq(){-uitous-}
 import AnnCoreSyn
 import CoreSyn
 
-import CoreUtils	( coreExprType, manifestlyWHNF, manifestlyBottom )
+import CoreUtils	( coreExprType )
+import CoreUnfold	( whnfOrBottom )
 import FreeVars		-- all of it
 import Id		( idType, mkSysLocal, toplevelishId,
 			  nullIdEnv, addOneToIdEnv, growIdEnvList,
@@ -466,7 +467,7 @@ setFloatLevel alreadyLetBound ctxt_lvl envs@(venv, tenv)
 
     offending tyvar = ids_only_lvl `ltLvl` tyvarLevel tenv tyvar
 
-    manifestly_whnf = manifestlyWHNF de_ann_expr || manifestlyBottom de_ann_expr
+    manifestly_whnf = whnfOrBottom de_ann_expr
 
     maybe_unTopify Top | not (canFloatToTop (ty, expr)) = Level 0 0
     maybe_unTopify lvl                                  = lvl
@@ -672,7 +673,7 @@ isWorthFloating alreadyLetBound expr
   | otherwise       = 	-- No point in adding a fresh let-binding for a WHNF, because
 			-- floating it isn't beneficial enough.
 		      isWorthFloatingExpr expr &&
-		      not (manifestlyWHNF expr || manifestlyBottom expr)
+		      not (whnfOrBottom expr)
 ********** -}
 
 isWorthFloatingExpr :: CoreExpr -> Bool
@@ -690,7 +691,7 @@ canFloatToTop :: (Type, CoreExprWithFVs) -> Bool
 canFloatToTop (ty, (FVInfo _ _ (LeakFree _), expr)) = True
 canFloatToTop (ty, (FVInfo _ _ MightLeak,    expr)) = isLeakFreeType [] ty
 
-valSuggestsLeakFree expr = manifestlyWHNF expr || manifestlyBottom expr
+valSuggestsLeakFree expr = whnfOrBottom expr
 \end{code}
 
 
diff --git a/ghc/compiler/simplCore/SimplCase.lhs b/ghc/compiler/simplCore/SimplCase.lhs
index 3a784494b0..ab3e4b29a6 100644
--- a/ghc/compiler/simplCore/SimplCase.lhs
+++ b/ghc/compiler/simplCore/SimplCase.lhs
@@ -16,9 +16,7 @@ IMPORT_DELOOPER(SmplLoop)		( simplBind, simplExpr, MagicUnfoldingFun )
 import BinderInfo	-- too boring to try to select things...
 import CmdLineOpts	( SimplifierSwitch(..) )
 import CoreSyn
-import CoreUnfold	( whnfDetails, mkConForm, mkLitForm,
-			  UnfoldingDetails(..), UnfoldingGuidance(..),
-			  FormSummary(..)
+import CoreUnfold	( Unfolding(..), UnfoldingGuidance(..), SimpleUnfolding 
 			)
 import CoreUtils	( coreAltsType, nonErrorRHSs, maybeErrorApp,
 			  unTagBindersAlts
@@ -34,7 +32,7 @@ import PrimOp		( primOpOkForSpeculation, PrimOp{-instance Eq-} )
 import SimplEnv
 import SimplMonad
 import SimplUtils	( mkValLamTryingEta )
-import Type		( isPrimType, maybeAppDataTyConExpandingDicts, mkFunTy, mkFunTys, eqTy )
+import Type		( isPrimType, getAppDataTyConExpandingDicts, mkFunTy, mkFunTys, eqTy )
 import TysPrim		( voidTy )
 import Unique		( Unique{-instance Eq-} )
 import Usage		( GenUsage{-instance Eq-} )
@@ -295,9 +293,9 @@ completeCase env scrut alts rhs_c
 
 		-- Eliminate unused rhss if poss
 	      rhss = case scrut_form of
-			OtherLitForm not_these -> [rhs | (alt_lit,rhs) <- alts,
-						       not (alt_lit `is_elem` not_these)
-						      ]
+			OtherLit not_these -> [rhs | (alt_lit,rhs) <- alts,
+						     not (alt_lit `is_elem` not_these)
+					      ]
 			other -> [rhs | (_,rhs) <- alts]
 
 	  AlgAlts alts deflt -> (deflt_binder_unused && all alt_binders_unused possible_alts,
@@ -308,7 +306,7 @@ completeCase env scrut alts rhs_c
 
 		-- Eliminate unused alts if poss
 	      possible_alts = case scrut_form of
-				OtherConForm not_these ->
+				OtherCon not_these ->
 					 	-- Remove alts which can't match
 					[alt | alt@(alt_con,_,_) <- alts,
 					       not (alt_con `is_elem` not_these)]
@@ -321,12 +319,12 @@ completeCase env scrut alts rhs_c
 
 	-- If the scrutinee is a variable, look it up to see what we know about it
     scrut_form = case scrut of
-		  Var v -> lookupUnfolding env v
-		  other   -> NoUnfoldingDetails
+		  Var v -> lookupRhsInfo env v
+		  other -> NoRhsInfo
 
 	-- If the scrut is already eval'd then there's no worry about
 	-- eliminating the case
-    scrut_is_evald = whnfDetails scrut_form
+    scrut_is_evald = isEvaluated scrut_form
 
     scrut_is_eliminable_primitive
       = case scrut of
@@ -360,9 +358,8 @@ completeCase env scrut alts rhs_c
     rhs1_is_scrutinee = case (scrut, rhs1) of
 			  (Var scrut_var, Var rhs_var)
 				-> case lookupId env rhs_var of
-				    Just (ItsAnAtom (VarArg rhs_var'))
-					-> rhs_var' == scrut_var
-				    other -> False
+				    VarArg rhs_var' -> rhs_var' == scrut_var
+				    other	    -> False
 			  other -> False
 
     is_elem x ys = isIn "completeCase" x ys
@@ -505,13 +502,17 @@ simplAlts env scrut (AlgAlts alts deflt) rhs_c
     simplDefault env scrut deflt deflt_form rhs_c	`thenSmpl` \ deflt' ->
     returnSmpl (AlgAlts alts' deflt')
   where
-    deflt_form = OtherConForm [con | (con,_,_) <- alts]
+    deflt_form = OtherCon [con | (con,_,_) <- alts]
     do_alt (con, con_args, rhs)
       = cloneIds env con_args				`thenSmpl` \ con_args' ->
 	let
 	    env1    = extendIdEnvWithClones env con_args con_args'
 	    new_env = case scrut of
-		       Var v -> extendUnfoldEnvGivenConstructor env1 v con con_args'
+		       Var v -> extendEnvGivenNewRhs env1 v (Con con args)
+			     where
+				(_, ty_args, _) = getAppDataTyConExpandingDicts (idType v)
+				args = map TyArg ty_args ++ map VarArg con_args'
+
 		       other -> env1
 	in
 	rhs_c new_env rhs 				`thenSmpl` \ rhs' ->
@@ -522,11 +523,11 @@ simplAlts env scrut (PrimAlts alts deflt) rhs_c
     simplDefault env scrut deflt deflt_form rhs_c	`thenSmpl` \ deflt' ->
     returnSmpl (PrimAlts alts' deflt')
   where
-    deflt_form = OtherLitForm [lit | (lit,_) <- alts]
+    deflt_form = OtherLit [lit | (lit,_) <- alts]
     do_alt (lit, rhs)
       = let
 	    new_env = case scrut of
-			Var v -> extendUnfoldEnvGivenFormDetails env v (mkLitForm lit)
+			Var v -> extendEnvGivenNewRhs env v (Lit lit)
 			other -> env
 	in
 	rhs_c new_env rhs 				`thenSmpl` \ rhs' ->
@@ -564,7 +565,7 @@ simplDefault
 	:: SimplEnv
 	-> OutExpr			-- Simplified scrutinee
 	-> InDefault 			-- Default alternative to be completed
-	-> UnfoldingDetails		-- Gives form of scrutinee
+	-> RhsInfo			-- Gives form of scrutinee
 	-> (SimplEnv -> InExpr -> SmplM OutExpr)		-- Old rhs handler
 	-> SmplM OutDefault
 
@@ -572,36 +573,27 @@ simplDefault env scrut NoDefault form rhs_c
   = returnSmpl NoDefault
 
 -- Special case for variable scrutinee; see notes above.
-simplDefault env (Var scrut_var) (BindDefault binder rhs) form_from_this_case rhs_c
+simplDefault env (Var scrut_var) (BindDefault binder@(_,occ_info) rhs) 
+	     info_from_this_case rhs_c
   = cloneId env binder 	`thenSmpl` \ binder' ->
     let
-      env1    = extendIdEnvWithAtom env binder (VarArg binder')
+      env1    = extendIdEnvWithClone env binder binder'
+      env2    = extendEnvGivenRhsInfo env1 binder' occ_info info_from_this_case
 
 	-- Add form details for the default binder
-      scrut_form = lookupUnfolding env scrut_var
-      final_form
-	= case (form_from_this_case, scrut_form) of
-	    (OtherConForm cs, OtherConForm ds) -> OtherConForm (cs++ds)
-	    (OtherLitForm cs, OtherLitForm ds) -> OtherLitForm (cs++ds)
-	    other 			       -> form_from_this_case
-
-      env2 = extendUnfoldEnvGivenFormDetails env1 binder' final_form
-
-	-- Change unfold details for scrut var.  We now want to unfold it
-	-- to binder'
-      new_scrut_var_form = GenForm WhnfForm (Var binder') UnfoldAlways
-
-      new_env    = extendUnfoldEnvGivenFormDetails env2 scrut_var new_scrut_var_form
-
+      scrut_info = lookupRhsInfo env scrut_var
+      env3       = extendEnvGivenRhsInfo env2 binder' occ_info scrut_info
+      new_env    = extendEnvGivenNewRhs env3 scrut_var (Var binder')
     in
     rhs_c new_env rhs			`thenSmpl` \ rhs' ->
     returnSmpl (BindDefault binder' rhs')
 
-simplDefault env scrut (BindDefault binder rhs) form rhs_c
+simplDefault env scrut (BindDefault binder@(_,occ_info) rhs) 
+	     info_from_this_case rhs_c
   = cloneId env binder 	`thenSmpl` \ binder' ->
     let
-	env1    = extendIdEnvWithAtom env binder (VarArg binder')
-	new_env = extendUnfoldEnvGivenFormDetails env1 binder' form
+	env1    = extendIdEnvWithClone env binder binder'
+	new_env = extendEnvGivenRhsInfo env1 binder' occ_info info_from_this_case
     in
     rhs_c new_env rhs			`thenSmpl` \ rhs' ->
     returnSmpl (BindDefault binder' rhs')
@@ -671,7 +663,8 @@ completeAlgCaseWithKnownCon env con con_args (AlgAlts alts deflt) rhs_c
       | alt_con == con
       = 	-- Matching alternative!
 	let
-	    new_env = extendIdEnvWithAtomList env (zipEqual "SimplCase" alt_args (filter isValArg con_args))
+	    new_env = extendIdEnvWithAtoms env 
+				(zipEqual "SimplCase" alt_args (filter isValArg con_args))
 	in
 	rhs_c new_env rhs
 
@@ -685,13 +678,11 @@ completeAlgCaseWithKnownCon env con con_args (AlgAlts alts deflt) rhs_c
 	  NoDefault 	 -> 	-- Blargh!
 	    panic "completeAlgCaseWithKnownCon: No matching alternative and no default"
 
-	  BindDefault binder rhs ->	-- OK, there's a default case
+	  BindDefault binder@(_,occ_info) rhs ->	-- OK, there's a default case
 			-- let-bind the binder to the constructor
 		cloneId env binder		`thenSmpl` \ id' ->
 		let
-		    env1    = extendIdEnvWithClone env binder id'
-		    new_env = extendUnfoldEnvGivenFormDetails env1 id'
-					(mkConForm con con_args)
+		    new_env = extendEnvGivenBinding env occ_info id' (Con con con_args)
 		in
 		rhs_c new_env rhs		`thenSmpl` \ rhs' ->
 		returnSmpl (Let (NonRec id' (Con con con_args)) rhs')
@@ -781,8 +772,8 @@ mkCoCase scrut (AlgAlts outer_alts
 	 v | scrut_is_var = Var scrut_var
 	   | otherwise    = Con con (map TyArg arg_tys ++ map VarArg args)
 
-    arg_tys = case (maybeAppDataTyConExpandingDicts (idType deflt_var)) of
-		Just (_, arg_tys, _) -> arg_tys
+    arg_tys = case (getAppDataTyConExpandingDicts (idType deflt_var)) of
+		(_, arg_tys, _) -> arg_tys
 
 mkCoCase scrut (PrimAlts
 		  outer_alts
diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs
index e2f3a7de7a..d8aa0070e2 100644
--- a/ghc/compiler/simplCore/SimplCore.lhs
+++ b/ghc/compiler/simplCore/SimplCore.lhs
@@ -34,7 +34,7 @@ import CmdLineOpts	( CoreToDo(..), SimplifierSwitch(..), switchIsOn,
 import CoreLint		( lintCoreBindings )
 import CoreSyn
 import CoreUnfold
-import CoreUtils	( substCoreBindings, manifestlyWHNF )
+import CoreUtils	( substCoreBindings, whnfOrBottom )
 import ErrUtils		( ghcExit )
 import FiniteMap	( FiniteMap )
 import FloatIn		( floatInwards )
@@ -58,7 +58,6 @@ import Pretty		( ppShow, ppAboves, ppAbove, ppCat, ppStr )
 import SAT		( doStaticArgs )
 import SimplMonad	( zeroSimplCount, showSimplCount, SimplCount )
 import SimplPgm		( simplifyPgm )
-import SimplVar		( leastItCouldCost )
 import Specialise
 import SpecUtils	( pprSpecErrs )
 import StrictAnal	( saWwTopBinds )
@@ -86,7 +85,7 @@ core2core :: [CoreToDo]			-- spec of what core-to-core passes to do
 	  -> [CoreBinding]		-- input...
 	  -> IO
 	      ([CoreBinding],	-- results: program, plus...
-	       IdEnv UnfoldingDetails,	--  unfoldings to be exported from here
+	       IdEnv Unfolding,	--  unfoldings to be exported from here
 	      SpecialiseData)		--  specialisation data
 
 core2core core_todos module_name ppr_style us local_tycons tycon_specs binds
@@ -305,9 +304,9 @@ will be visible on the other side of an interface, too.
 
 \begin{code}
 calcInlinings :: Bool	-- True => inlinings with _scc_s are OK
-	      -> IdEnv UnfoldingDetails
+	      -> IdEnv Unfolding
 	      -> [CoreBinding]
-	      -> IdEnv UnfoldingDetails
+	      -> IdEnv Unfolding
 
 calcInlinings scc_s_OK inline_env_so_far top_binds
   = let
@@ -319,9 +318,9 @@ calcInlinings scc_s_OK inline_env_so_far top_binds
     pp_item (binder, details)
       = ppCat [ppr PprDebug binder, ppStr "=>", pp_det details]
       where
-    	pp_det NoUnfoldingDetails   = ppStr "_N_"
+    	pp_det NoUnfolding   = ppStr "_N_"
 --LATER:	pp_det (IWantToBeINLINEd _) = ppStr "INLINE"
-    	pp_det (GenForm _ expr guide)
+    	pp_det (CoreUnfolding (SimpleUnfolding _ guide expr))
     	  = ppAbove (ppr PprDebug guide) (ppr PprDebug expr)
     	pp_det other	    	    = ppStr "???"
 
@@ -362,7 +361,7 @@ calcInlinings scc_s_OK inline_env_so_far top_binds
 
       | rhs_mentions_an_unmentionable
       || (not explicit_INLINE_requested
-	  && (rhs_looks_like_a_caf || guidance_says_don't || guidance_size_too_big))
+	  && (rhs_looks_like_a_caf || guidance_size_too_big))
       = let
 	    my_my_trace
 	      = if explicit_INLINE_requested
@@ -429,38 +428,16 @@ calcInlinings scc_s_OK inline_env_so_far top_binds
 	guidance_size
 	  = case guidance of
 	      UnfoldAlways  	    	  -> 0 -- *extremely* small
-	      EssentialUnfolding    	  -> 0 -- ditto
 	      UnfoldIfGoodArgs _ _ _ size -> size
 
-	guidance_says_don't = case guidance of { UnfoldNever -> True; _ -> False }
-
 	guidance_size_too_big
 	    -- Does the guidance suggest that this unfolding will
 	    -- be of no use *no matter* the arguments given to it?
 	    -- Could be more sophisticated...
-	  = case guidance of
-	      UnfoldAlways  	 -> False
-	      EssentialUnfolding -> False
-	      UnfoldIfGoodArgs _ no_val_args arg_info_vec size
-
-		-> if explicit_creation_threshold then
-		      False 	-- user set threshold; don't second-guess...
-
-		   else if no_val_args == 0 && rhs_looks_like_a_data_val then
-		      False	-- we'd like a top-level data constr to be
-				-- visible even if it is never unfolded
-		   else
-		      let
-			  cost
-			    = leastItCouldCost con_discount_weight size no_val_args
-				arg_info_vec rhs_arg_tys
-		      in
---		      (if (unfold_use_threshold < cost) then (pprTrace "cost:" (ppInt cost)) else \x->x ) (
-		      unfold_use_threshold < cost
---		      )
+	  = not (couldBeSmallEnoughToInline con_discount_weight unfold_use_threshold guidance)
 
 
-	rhs_looks_like_a_caf = not (manifestlyWHNF rhs)
+	rhs_looks_like_a_caf = not (whnfOrBottom rhs)
 
 	rhs_looks_like_a_data_val
 	  = case (collectBinders rhs) of
diff --git a/ghc/compiler/simplCore/SimplEnv.lhs b/ghc/compiler/simplCore/SimplEnv.lhs
index 0ec9ac5025..b75369b092 100644
--- a/ghc/compiler/simplCore/SimplEnv.lhs
+++ b/ghc/compiler/simplCore/SimplEnv.lhs
@@ -7,34 +7,34 @@
 #include "HsVersions.h"
 
 module SimplEnv (
-	nullSimplEnv,
+	nullSimplEnv, combineSimplEnv,
 	pprSimplEnv, -- debugging only
 
-	replaceInEnvs, nullInEnvs,
-
 	extendTyEnv, extendTyEnvList,
 	simplTy, simplTyInId,
 
-	extendIdEnvWithAtom, extendIdEnvWithAtomList,
-	extendIdEnvWithInlining,
+	extendIdEnvWithAtom, extendIdEnvWithAtoms,
 	extendIdEnvWithClone, extendIdEnvWithClones,
 	lookupId,
 
-	extendUnfoldEnvGivenRhs,
-	extendUnfoldEnvGivenFormDetails,
-	extendUnfoldEnvGivenConstructor,
+
+	markDangerousOccs,
+	lookupRhsInfo, lookupOutIdEnv, isEvaluated,
+	extendEnvGivenBinding, extendEnvGivenNewRhs,
+	extendEnvForRecBinding, extendEnvGivenRhsInfo,
+
 	lookForConstructor,
-	lookupUnfolding, filterUnfoldEnvForInlines,
 
-	getSwitchChecker, switchIsSet,
+	getSwitchChecker, switchIsSet, getSimplIntSwitch, switchOffInlining,
 
-	setEnclosingCC,
+	setEnclosingCC, getEnclosingCC,
 
 	-- Types
 	SYN_IE(SwitchChecker),
-	SimplEnv, EnclosingCcDetails(..),
-	SYN_IE(InIdEnv), IdVal(..), SYN_IE(InTypeEnv),
-	UnfoldEnv, UnfoldItem, UnfoldConApp,
+	SimplEnv, 
+	SYN_IE(InIdEnv), SYN_IE(InTypeEnv),
+	UnfoldConApp,
+	RhsInfo(..),
 
 	SYN_IE(InId),  SYN_IE(InBinder),  SYN_IE(InBinding),  SYN_IE(InType),
 	SYN_IE(OutId), SYN_IE(OutBinder), SYN_IE(OutBinding), SYN_IE(OutType),
@@ -47,26 +47,28 @@ IMP_Ubiq(){-uitous-}
 
 IMPORT_DELOOPER(SmplLoop)		-- breaks the MagicUFs / SimplEnv loop
 
-import BinderInfo	( orBinderInfo, oneSafeOcc,
+import BinderInfo	( orBinderInfo, noBinderInfo,
 			  BinderInfo(..){-instances, too-}, FunOrArg, DuplicationDanger, InsideSCC
 			)
 import CgCompInfo	( uNFOLDING_CREATION_THRESHOLD )
-import CmdLineOpts	( switchIsOn, intSwitchSet, SimplifierSwitch(..), SwitchResult )
+import CmdLineOpts	( switchIsOn, intSwitchSet, SimplifierSwitch(..), SwitchResult(..) )
 import CoreSyn
-import CoreUnfold	( UnfoldingDetails(..), mkGenForm, mkConForm,
-			  calcUnfoldingGuidance, UnfoldingGuidance(..),
-			  mkFormSummary, FormSummary(..)
+import CoreUnfold	( mkFormSummary, exprSmallEnoughToDup, 
+			  Unfolding(..), SimpleUnfolding(..), FormSummary(..),
+			  mkSimpleUnfolding,
+			  calcUnfoldingGuidance, UnfoldingGuidance(..)
 			)
-import CoreUtils	( manifestlyWHNF, exprSmallEnoughToDup )
+import CoreUtils	( coreExprCc, unTagBinders )
+import CostCentre	( CostCentre, noCostCentre, noCostCentreAttached )
 import FiniteMap	-- lots of things
-import Id		( idType, getIdUnfolding, getIdStrictness,
+import Id		( idType, getIdUnfolding, getIdStrictness, idWantsToBeINLINEd,
 			  applyTypeEnvToId,
 			  nullIdEnv, growIdEnvList, rngIdEnv, lookupIdEnv,
-			  addOneToIdEnv, modifyIdEnv, mkIdSet,
+			  addOneToIdEnv, modifyIdEnv, mkIdSet, modifyIdEnv_Directly,
 			  SYN_IE(IdEnv), SYN_IE(IdSet), GenId )
 import IdInfo		( bottomIsGuaranteed, StrictnessInfo )
 import Literal		( isNoRepLit, Literal{-instances-} )
-import Maybes		( maybeToBool )
+import Maybes		( maybeToBool, expectJust )
 import Name		( isLocallyDefined )
 import OccurAnal	( occurAnalyseExpr )
 import Outputable	( Outputable(..){-instances-} )
@@ -79,8 +81,7 @@ import TyVar		( nullTyVarEnv, addOneToTyVarEnv, growTyVarEnvList,
 			  SYN_IE(TyVarEnv), GenTyVar{-instance Eq-}
 			)
 import Unique		( Unique{-instance Outputable-} )
-import UniqFM		( addToUFM_Directly, lookupUFM_Directly, delFromUFM_Directly,
-			  delFromUFM, ufmToList
+import UniqFM		( addToUFM_C, ufmToList, eltsUFM
 			)
 --import UniqSet		-- lots of things
 import Usage		( SYN_IE(UVar), GenUsage{-instances-} )
@@ -96,6 +97,27 @@ cmpType = panic "cmpType (SimplEnv)"
 %*									*
 %************************************************************************
 
+\begin{code}
+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 OutId	= Id			-- Cloned
+type OutBinder	= Id
+type OutType	= Type			-- Cloned
+type OutBinding	= CoreBinding
+type OutExpr	= CoreExpr
+type OutAlts	= CoreCaseAlts
+type OutDefault	= CoreCaseDefault
+type OutArg	= CoreArg
+
+type SwitchChecker = SimplifierSwitch -> SwitchResult
+\end{code}
 
 %************************************************************************
 %*									*
@@ -122,344 +144,26 @@ inside the Ids, etc.).
 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
 
-	EnclosingCcDetails -- the enclosing cost-centre (when profiling)
-
-	InTypeEnv	-- For cloning types
-			-- Domain is all in-scope type variables
-
-	InIdEnv		-- IdEnv
-			-- Domain is
-			-- 	*all*
-			-- 	*in-scope*,
-			--	*locally-defined*
-			-- 	*InIds*
-			-- (Could omit the exported top-level guys,
-			-- since their names mustn't change; and ditto
-			-- the non-exported top-level guys which you
-			-- don't want to macro-expand, since their
-			-- names need not change.)
-			--
-			-- Starts off empty
-
-	UnfoldEnv	-- Domain is any *OutIds*, including imports
-			-- where we know something more than the
-			-- interface file tells about their value (see
-			-- below)
 
 nullSimplEnv :: SwitchChecker -> SimplEnv
 
 nullSimplEnv sw_chkr
-  = SimplEnv sw_chkr NoEnclosingCcDetails nullTyVarEnv nullIdEnv null_unfold_env
-
-pprSimplEnv (SimplEnv _ _ ty_env id_env (UFE unfold_env _ _))
-  = ppAboves [
-	ppStr "** Type Env ** ????????", -- ppr PprDebug ty_env,
-	ppSP, ppStr "** Id Env ** ?????????",
---	ppAboves [ pp_id_entry x | x <- getIdEnvMapping id_env ],
-	ppSP, ppStr "** Unfold Env **",
-	ppAboves [ pp_uf_entry x | x <- rngIdEnv unfold_env ]
-    ]
-  where
-    pp_id_entry (v, idval)
-      = ppCat [ppr PprDebug v, ppStr "=>",
-	       case idval of
-		 InlineIt _ _ e -> ppCat [ppStr "InlineIt:", ppr PprDebug e]
-		 ItsAnAtom a    -> ppCat [ppStr "Atom:", ppr PprDebug a]
-	      ]
-
-    pp_uf_entry (UnfoldItem v form encl_cc)
-      = ppCat [ppr PprDebug v, ppStr "=>",
-	       case form of
-		 NoUnfoldingDetails -> ppStr "NoUnfoldingDetails"
-		 OtherLitForm ls -> ppCat [ppStr "Other lit:", ppInterleave (ppStr ", ")
-						               [ppr PprDebug l | l <- ls]]
-		 OtherConForm cs -> ppCat [ppStr "OtherCon:", ppInterleave (ppStr ", ")
-							      [ppr PprDebug c | c <- cs]]
-		 GenForm w e g -> ppCat [ppStr "UF:",	ppr PprDebug w,
-							ppr PprDebug g, ppr PprDebug e]
-		 MagicForm s _   -> ppCat [ppStr "Magic:", ppr PprDebug s]
-	      ]
-\end{code}
-
-%************************************************************************
-%*									*
-\subsubsection{The @IdVal@ type (for the ``IdEnv'')}
-%*									*
-%************************************************************************
-
-The unfoldings for imported things are mostly kept within the Id
-itself; nevertheless, they {\em can} get into the @UnfoldEnv@.  For
-example, suppose \tr{x} is imported, and we have
-\begin{verbatim}
-	case x of
-	  (p,q) -> <body>
-\end{verbatim}
-Then within \tr{<body>}, we know that \tr{x} is a pair with components
-\tr{p} and \tr{q}.
-
-\begin{code}
-type InIdEnv = IdEnv IdVal	-- Maps InIds to their value
-
-data IdVal
-  = InlineIt InIdEnv InTypeEnv InExpr
-		-- No binding of the Id is left;
-		-- You *have* to replace any occurences
-		-- of the id with this expression.
-		-- Rather like a macro, really
-		-- NB: the InIdEnv/InTypeEnv is necessary to prevent
-		-- name caputure. Consider:
-		--	let y = ...
-		--	    x = ...y...
-		-- 	    y = ...
-		--	in ...x...
-		-- If x gets an InlineIt, we must remember
-		-- the correct binding for y.
-
-  | ItsAnAtom OutArg	-- Used either (a) to record the cloned Id
-			-- or (b) 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.
-\end{code}
-
-%************************************************************************
-%*									*
-\subsubsection{The @UnfoldEnv@ type}
-%*									*
-%************************************************************************
-
-The @UnfoldEnv@ contains information about the value of some of the
-in-scope identifiers.  It obeys the following invariant:
-
-	If the @UnfoldEnv@ contains information, it is safe to use it!
+  = SimplEnv sw_chkr noCostCentre nullTyVarEnv nullIdEnv nullIdEnv nullConApps
 
-In particular, if the @UnfoldEnv@ contains details of an unfolding of
-an Id, then it's safe to use the unfolding.  If, for example, the Id
-is used many times, then its unfolding won't be put in the UnfoldEnv
-at all.
+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 @UnfoldEnv@ (used to be [WDP 94/06]) a simple association list
-because (a)~it's small, and (b)~we need to search its {\em range} as
-well as its domain.
-
-\begin{code}
-data UnfoldItem -- a glorified triple...
-  = UnfoldItem	OutId			-- key: used in lookForConstructor
-		UnfoldingDetails	-- for that Id
-		EnclosingCcDetails	-- so that if we do an unfolding,
-					-- we can "wrap" it in the CC
-					-- that was in force.
-
-data UnfoldConApp -- yet another glorified pair
-  = UCA		OutId			-- data constructor
-		[OutArg]		-- *value* arguments; see use below
-
-data UnfoldEnv	-- yup, a glorified triple...
-  = UFE		(IdEnv UnfoldItem)	-- Maps an OutId => its UnfoldItem
-
-		(IdEnv (Id,BinderInfo))	-- Occurrence info for some (but not necessarily all)
-					-- in-scope ids.  The "Id" part is just so that
-					-- we can recover the domain of the mapping, which
-					-- IdEnvs don't allow directly.
-					--
-					-- Anything that isn't in here
-					-- should be assumed to occur many times.
-					-- The things in here all occur once, and the 
-					-- binder-info tells about whether that "once"
-					-- is inside a lambda, or perhaps once in each branch
-					-- of a case etc.
-					-- We keep this info so we can modify it when
-					-- something changes.
-
-		(FiniteMap UnfoldConApp [([Type], OutId)])
-					-- 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 IdEnv
-					-- (1st part of UFE)
-
-null_unfold_env = UFE nullIdEnv nullIdEnv emptyFM
+pprSimplEnv (SimplEnv _ _ ty_env in_id_env out_id_env con_apps) = panic "pprSimplEnv"
 \end{code}
 
-The @UnfoldEnv@ type.  We expect on the whole that an @UnfoldEnv@ will
-be small, because it contains bindings only for those things whose
-form or unfolding is known.  Basically it maps @Id@ to their
-@UnfoldingDetails@ (and @EnclosingCcDetails@---boring...), but we also
-need to search it associatively, to look for @Id@s which have a given
-constructor form.
-
-We implement it with @IdEnvs@, possibly overkill, but sometimes these
-things silently grow quite big....  Here are some local functions used
-elsewhere in the module:
-
-\begin{code}
-grow_unfold_env   :: UnfoldEnv -> OutId -> BinderInfo -> UnfoldingDetails -> EnclosingCcDetails -> UnfoldEnv
-lookup_unfold_env :: UnfoldEnv -> OutId -> UnfoldingDetails
-lookup_unfold_env_encl_cc
-		  :: UnfoldEnv -> OutId -> EnclosingCcDetails
-
-grow_unfold_env full_u_env _ _ NoUnfoldingDetails _ = full_u_env
-
-grow_unfold_env (UFE u_env occ_env con_apps) id occ_info uf_details encl_cc
-  = UFE (addOneToIdEnv u_env id (UnfoldItem id uf_details encl_cc))
-	new_occ_env
-	new_con_apps
-  where
-    new_occ_env = modify_occ_info occ_env id occ_info
-
-    new_con_apps
-      = case uf_details of
-	  GenForm WhnfForm (Con con args) UnfoldAlways -> snd (lookup_conapp_help con_apps con args id)
-	  not_a_constructor -> con_apps -- unchanged
-
-addto_unfold_env (UFE u_env occ_env con_apps) extra_items
-  = ASSERT(not (any constructor_form_in_those extra_items))
-    -- otherwise, we'd need to change con_apps
-    UFE (growIdEnvList u_env extra_items) occ_env con_apps
-  where
-    constructor_form_in_those (_, UnfoldItem _ (GenForm WhnfForm (Con _ _) UnfoldAlways) _) = True
-    constructor_form_in_those _ = False
-
-rng_unfold_env (UFE u_env _ _) = rngIdEnv u_env
-
-get_interesting_ids (UFE _ occ_env _)
-  = mkIdSet [ i | (_,(i,_)) <- ufmToList occ_env ]
-
-foldr_occ_env fun (UFE u_env occ_env con_apps) stuff
-  = UFE u_env (foldr fun occ_env stuff) con_apps
-
-lookup_unfold_env (UFE u_env _ _) id
-  = case (lookupIdEnv u_env id) of
-      Nothing		       -> NoUnfoldingDetails
-      Just (UnfoldItem _ uf _) -> uf
-
-lookup_unfold_env_encl_cc (UFE u_env _ _) id
-  = case (lookupIdEnv u_env id) of
-      Nothing	    	    	    -> NoEnclosingCcDetails
-      Just (UnfoldItem _ _ encl_cc) -> encl_cc
-
-lookup_conapp (UFE _ _ con_apps) con args
-  = fst (lookup_conapp_help con_apps con args (panic "lookup_conapp"))
-
--- Returns two things; we just fst or snd the one we want:
-lookup_conapp_help con_apps con args outid
-  = case (span notValArg args) of { (ty_args, val_args) ->
-    let
-	 entry   = UCA con val_args
-	 arg_tys = [ t | TyArg t <- ty_args ]
-    in
-    case (lookupFM con_apps entry) of
-      Nothing -> (Nothing,
-		 addToFM con_apps entry [(arg_tys, outid)])
-      Just assocs
-	-> ASSERT(not (null assocs))
-	   case [ oid | (ts,oid) <- assocs, ts `eq_tys` arg_tys ] of
-	     [o] -> (Just o,
-		    con_apps) -- unchanged; we hang onto what we have
-	     []  -> (Nothing,
-		    addToFM con_apps entry ((arg_tys, outid) : assocs))
-	     _   -> panic "grow_unfold_env:dup in assoc list"
-    }
-  where
-    eq_tys ts1 ts2
-      = case (cmpList cmp_ty ts1 ts2) of { EQ_ -> True; _ -> False }
-
-    cmp_ty ty1 ty2 -- NB: we really only know how to do *equality* on types
-      = if (ty1 `eqTy` ty2) then EQ_ else LT_{-random choice-}
-
-modify_occ_info occ_env id new_occ@(OneOcc _ _ _ _ _)
-  = modifyIdEnv occ_env (\ (i,o) -> (i, orBinderInfo o new_occ)) id
-
-modify_occ_info occ_env id other_new_occ
-  = 	-- Many or Dead occurrence, just delete from occ_env
-    delFromUFM occ_env id
-\end{code}
-
-The main thing about @UnfoldConApp@ is that it has @Ord@ defined on
-it, so we can use it for a @FiniteMap@ key.
-\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
-  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}
-
-%************************************************************************
-%*									*
-\subsubsection{The @EnclosingCcDetails@ type}
-%*									*
-%************************************************************************
-
-\begin{code}
-data EnclosingCcDetails
-  = NoEnclosingCcDetails
-  | EnclosingCC	    CostCentre
-\end{code}
-
-%************************************************************************
-%*									*
-\subsubsection{The ``InXXX'' and ``OutXXX'' type synonyms}
-%*									*
-%************************************************************************
-
-\begin{code}
-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 OutId	= Id			-- Cloned
-type OutBinder	= Id
-type OutType	= Type			-- Cloned
-type OutBinding	= CoreBinding
-type OutExpr	= CoreExpr
-type OutAlts	= CoreCaseAlts
-type OutDefault	= CoreCaseDefault
-type OutArg	= CoreArg
-
-type SwitchChecker = SimplifierSwitch -> SwitchResult
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection{@SimplEnv@ handling}
-%*									*
-%************************************************************************
 
 %************************************************************************
 %*									*
@@ -469,11 +173,23 @@ type SwitchChecker = SimplifierSwitch -> SwitchResult
 
 \begin{code}
 getSwitchChecker :: SimplEnv -> SwitchChecker
-getSwitchChecker (SimplEnv chkr _ _ _ _) = chkr
+getSwitchChecker (SimplEnv chkr _ _ _ _ _) = chkr
 
 switchIsSet :: SimplEnv -> SimplifierSwitch -> Bool
-switchIsSet (SimplEnv chkr _ _ _ _) switch
+switchIsSet (SimplEnv chkr _ _ _ _ _) switch
   = switchIsOn chkr switch
+
+getSimplIntSwitch :: SwitchChecker -> (Int-> SimplifierSwitch) -> Int
+getSimplIntSwitch chkr switch
+  = expectJust "getSimplIntSwitch" (intSwitchSet chkr switch)
+
+	-- Crude, but simple
+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 out_id_env con_apps
+  where
+    chkr' EssentialUnfoldingsOnly = SwBool True
+    chkr' other			  = chkr other
 \end{code}
 
 %************************************************************************
@@ -483,10 +199,13 @@ switchIsSet (SimplEnv chkr _ _ _ _) switch
 %************************************************************************
 
 \begin{code}
-setEnclosingCC :: SimplEnv -> EnclosingCcDetails -> SimplEnv
+setEnclosingCC :: SimplEnv -> CostCentre -> SimplEnv
+
+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
 
-setEnclosingCC (SimplEnv chkr _ ty_env id_env unfold_env) encl_cc
-  = SimplEnv chkr encl_cc ty_env id_env unfold_env
+getEnclosingCC :: SimplEnv -> CostCentre
+getEnclosingCC (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) = encl_cc
 \end{code}
 
 %************************************************************************
@@ -499,33 +218,19 @@ setEnclosingCC (SimplEnv chkr _ ty_env id_env unfold_env) encl_cc
 type InTypeEnv = TypeEnv	-- Maps InTyVars to OutTypes
 
 extendTyEnv :: SimplEnv -> TyVar -> Type -> SimplEnv
-extendTyEnv (SimplEnv chkr encl_cc ty_env id_env unfold_env) tyvar ty
-  = SimplEnv chkr encl_cc new_ty_env id_env unfold_env
+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
 
 extendTyEnvList :: SimplEnv -> [(TyVar,Type)] -> SimplEnv
-extendTyEnvList (SimplEnv chkr encl_cc ty_env id_env unfold_env) pairs
-  = SimplEnv chkr encl_cc new_ty_env id_env unfold_env
+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
 
-simplTy     (SimplEnv _ _ ty_env _ _) ty = applyTypeEnvToTy ty_env ty
-simplTyInId (SimplEnv _ _ ty_env _ _) id = applyTypeEnvToId ty_env id
-\end{code}
-
-@replaceInEnvs@ is used to install saved type and id envs
-when pulling an un-simplified expression out of the environment, which
-was saved with its environments.
-
-\begin{code}
-nullInEnvs = (nullTyVarEnv, nullIdEnv) :: (InTypeEnv,InIdEnv)
-
-replaceInEnvs :: SimplEnv -> (InTypeEnv,InIdEnv) -> SimplEnv
-
-replaceInEnvs (SimplEnv chkr encl_cc ty_env id_env unfold_env)
-	      (new_ty_env, new_id_env)
-  = SimplEnv chkr encl_cc new_ty_env new_id_env unfold_env
+simplTy     (SimplEnv _ _ ty_env _ _ _) ty = applyTypeEnvToTy ty_env ty
+simplTyInId (SimplEnv _ _ ty_env _ _ _) id = applyTypeEnvToId ty_env id
 \end{code}
 
 %************************************************************************
@@ -535,129 +240,129 @@ replaceInEnvs (SimplEnv chkr encl_cc ty_env id_env unfold_env)
 %************************************************************************
 
 \begin{code}
-extendIdEnvWithAtom
-	:: SimplEnv
-	-> InBinder -> OutArg{-Val args only, please-}
-	-> SimplEnv
-
-extendIdEnvWithAtom (SimplEnv chkr encl_cc ty_env id_env unfold_env)
-		    (in_id,occ_info) atom@(LitArg lit)
-  = SimplEnv chkr encl_cc ty_env new_id_env unfold_env
-  where
-    new_id_env = addOneToIdEnv id_env in_id (ItsAnAtom atom)
+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.
+\end{code}
 
-extendIdEnvWithAtom (SimplEnv chkr encl_cc ty_env id_env (UFE u_env occ_env con_apps))
-	    	    (in_id, occ_info) atom@(VarArg out_id)
-  = SimplEnv chkr encl_cc ty_env new_id_env new_unfold_env
-  where
-    new_id_env     = addOneToIdEnv id_env in_id (ItsAnAtom atom)
-    new_unfold_env = UFE u_env (modify_occ_info occ_env out_id occ_info) con_apps
-			-- Modify occ info for out_id
+\begin{code}
+lookupId :: SimplEnv -> Id -> OutArg
 
-#ifdef DEBUG
-extendIdEnvWithAtom _ _ _ = panic "extendIdEnvWithAtom: non-Val arg!"
-#endif
+lookupId (SimplEnv _ _ _ in_id_env _ _) id
+  = case (lookupIdEnv in_id_env id) of
+      Just atom -> atom
+      Nothing   -> VarArg id
+\end{code}
 
-extendIdEnvWithAtomList
+\begin{code}
+extendIdEnvWithAtom
 	:: SimplEnv
-	-> [(InBinder, OutArg)]
-	-> SimplEnv
-extendIdEnvWithAtomList = foldr (\ (bndr,val) env -> extendIdEnvWithAtom env bndr val)
-
-extendIdEnvWithInlining
-	:: SimplEnv		-- The Env to modify
-	-> SimplEnv		-- The Env to record in the inlining.  Usually the
-				-- same as the previous one, except in the recursive case
-	-> InBinder -> InExpr
+	-> InBinder
+        -> OutArg{-Val args only, please-}
 	-> SimplEnv
 
-extendIdEnvWithInlining (SimplEnv chkr encl_cc ty_env        id_env        unfold_env)
-			~(SimplEnv _   _       inline_ty_env inline_id_env _         )
-			(in_id,occ_info)
-			expr
-  = SimplEnv chkr encl_cc ty_env new_id_env unfold_env
+extendIdEnvWithAtom (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
+		    (in_id,occ_info) atom
+  = SimplEnv chkr encl_cc ty_env new_in_id_env new_out_id_env con_apps
   where
-    new_id_env = addOneToIdEnv id_env in_id (InlineIt inline_id_env inline_ty_env expr)
+    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)
 
-extendIdEnvWithClone
-	:: SimplEnv
-	-> InBinder	-- Old binder; binderinfo ignored
-	-> OutId	-- Its new clone, as an Id
-	-> SimplEnv
+extendIdEnvWithAtoms :: SimplEnv -> [(InBinder, OutArg)] -> SimplEnv
+extendIdEnvWithAtoms = foldr (\ (bndr,val) env -> extendIdEnvWithAtom env bndr val)
 
-extendIdEnvWithClone (SimplEnv chkr encl_cc ty_env id_env unfold_env)
-	(in_id,_) out_id
-  = SimplEnv chkr encl_cc ty_env new_id_env unfold_env
-  where
-    new_id_env = addOneToIdEnv id_env in_id (ItsAnAtom (VarArg out_id))
 
-extendIdEnvWithClones	-- Like extendIdEnvWithClone
-	:: SimplEnv
-	-> [InBinder]
-	-> [OutId]
-	-> SimplEnv
+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 chkr encl_cc ty_env id_env unfold_env)
-	in_binders out_ids
-  = SimplEnv chkr encl_cc ty_env new_id_env unfold_env
+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_id_env = growIdEnvList id_env (zipEqual "extendIdEnvWithClones" in_ids out_vals)
-    in_ids     = [id | (id,_) <- in_binders]
-    out_vals   = [ItsAnAtom (VarArg out_id) | out_id <- out_ids]
-
-lookupId :: SimplEnv -> Id -> Maybe IdVal
-
-lookupId (SimplEnv _ _ _ id_env _) id
-#ifndef DEBUG
-  = lookupIdEnv id_env id
-#else
-  = case (lookupIdEnv id_env id) of
-      xxx@(Just _) -> xxx
-      xxx	   -> --false!: ASSERT(not (isLocallyDefined id))
-		      xxx
-#endif
+    new_in_id_env = growIdEnvList in_id_env bindings
+    bindings      = zipEqual "extendIdEnvWithClones"
+		 	     [id | (id,_) <- in_binders]
+			     (map VarArg out_ids)
 \end{code}
 
 %************************************************************************
 %*									*
-\subsubsection{The @UnfoldEnv@}
+\subsubsection{The @OutIdEnv@}
 %*									*
 %************************************************************************
 
+
+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}
-extendUnfoldEnvGivenFormDetails
-	:: SimplEnv
-	-> OutId
-	-> UnfoldingDetails
-	-> SimplEnv
+type OutIdEnv = IdEnv (OutId, BinderInfo, RhsInfo)
 
-extendUnfoldEnvGivenFormDetails
-	env@(SimplEnv chkr encl_cc ty_env id_env unfold_env)
-	id details
-  = case details of
-      NoUnfoldingDetails -> env
-      good_details	 -> SimplEnv chkr encl_cc ty_env id_env new_unfold_env
-	where
-	  new_unfold_env = grow_unfold_env unfold_env id fake_occ_info good_details encl_cc
-	  fake_occ_info  = {-ToDo!-} ManyOcc 0 -- generally paranoid
-
-extendUnfoldEnvGivenConstructor -- specialised variant
-	:: SimplEnv
-	-> OutId		-- bind this to...
-	-> Id -> [OutId]	-- "con <tys-to-be-invented> args"
-	-> SimplEnv
+\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.
 
-extendUnfoldEnvGivenConstructor env var con args
-  = let
-	-- conjure up the types to which the con should be applied
-	scrut_ty	= idType var
-	(_, ty_args, _) = getAppDataTyConExpandingDicts scrut_ty
-    in
-    extendUnfoldEnvGivenFormDetails
-      env var (mkConForm con (map TyArg ty_args ++ map VarArg args))
+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)
+  = (id, occ, new_info)
+  where
+    new_info = case (info1, info2) of
+		(OtherLit ls1, OtherLit ls2) -> OtherLit (ls1++ls2)
+		(OtherCon cs1, OtherCon cs2) -> OtherCon (cs1++cs2)
+		(_,            NoRhsInfo)    -> info1
+		other	       		     -> info2
 \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}
+
 @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:
@@ -699,146 +404,157 @@ of the RHS.  In the example we'd go back and record that r_index is now used
 inside a lambda.
 
 \begin{code}
-extendUnfoldEnvGivenRhs
-	:: SimplEnv
-	-> InBinder
-	-> OutId	-- Note: *must* be an "out" Id (post-cloning)
-	-> OutExpr	-- Its rhs (*simplified*)
-	-> SimplEnv
-
-extendUnfoldEnvGivenRhs env@(SimplEnv chkr encl_cc ty_env id_env unfold_env)
-			binder@(_,occ_info) out_id rhs
-  = SimplEnv chkr encl_cc ty_env id_env new_unfold_env
+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_con_apps   = extendConApps con_apps out_id rhs
+    new_out_id_env = case guidance of
+			UnfoldNever -> out_id_env		-- No new stuff to put in
+		        other	    -> out_id_env_with_unfolding
+
+	-- If there is an unfolding, we add rhs-info for out_id,
+	-- *and* modify the occ info for rhs's interesting free variables.
+	--
+	-- If the out_id is already in the OutIdEnv, then just replace the
+	-- unfolding, leaving occurrence info alone (this must then
+	-- be a call via extendEnvGivenNewRhs).
+    out_id_env_with_unfolding = foldl modifyOccInfo env1 (ufmToList fv_occ_info)
+    env1 		      =	addToUFM_C modifyOutEnvItem out_id_env out_id 
+					   (out_id, occ_info, OutUnfolding unf_cc unfolding)
+
 	-- 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) = occurAnalyseExpr interesting_fvs rhs
+    interesting_fvs	    = mkIdSet [id | (id,OneOcc _ _ _ _ _,_) <- eltsUFM out_id_env]
+
+	-- Compute unfolding details
+    unfolding    = SimpleUnfolding form_summary guidance template
+    form_summary = mkFormSummary rhs
+
+    guidance | not (switchIsSet env IgnoreINLINEPragma) && idWantsToBeINLINEd out_id
+	     = UnfoldAlways
 
-    interesting_fvs = get_interesting_ids unfold_env   -- Ids in dom of OccEnv
+             | otherwise
+	     = calcUnfoldingGuidance True{-sccs OK-} bOMB_OUT_SIZE rhs
+
+    bOMB_OUT_SIZE = getSimplIntSwitch chkr SimplUnfoldingCreationThreshold
+
+	-- Compute cost centre for thing
+    unf_cc  | noCostCentreAttached expr_cc = encl_cc
+	    | otherwise		           = expr_cc
+	    where
+	      expr_cc =  coreExprCc rhs
+
+extendEnvForRecBinding env@(SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
+		       (out_id, ((_,occ_info), old_rhs))
+  = SimplEnv chkr encl_cc ty_env in_id_env new_out_id_env 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
+
+	-- 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, InUnfolding env unfolding)
 
 	-- Compute unfolding details
-    details = mkGenForm (mkFormSummary (getIdStrictness out_id) rhs)
-			template guidance
-
-	-- Compute resulting unfold env
-    new_unfold_env = case details of
-			NoUnfoldingDetails  -> unfold_env
-			other		    -> unfold_env1
-
-	-- Add unfolding to unfold env
-    unfold_env1 = grow_unfold_env unfold_env out_id occ_info details encl_cc
-
-{- OLD: done in grow_unfold_env
-	-- Modify unfoldings of free vars of rhs, based on their
-	-- occurrence info in the rhs [see notes above]
-    unfold_env2
-      = foldr_occ_env modify unfold_env1 (ufmToList fv_occ_info)
-      where
-	modify :: (Unique, (Id,BinderInfo)) -> IdEnv (Id,BinderInfo) -> IdEnv (Id,BinderInfo)
-	modify (u, item@(i,occ_info)) env
-	  = if maybeToBool (lookupUFM_Directly env u) then
-		-- it occurred before, so now it occurs multiple times;
-		-- therefore, *delete* it from the occ(urs once) env.
-		delFromUFM_Directly env u
-
-	    else if not (oneSafeOcc ok_to_dup occ_info) then
-		env -- leave it alone
-	    else
-		addToUFM_Directly env u item
--}
-
-	-- Compute unfolding guidance
-    guidance = if simplIdWantsToBeINLINEd out_id env
-	       then UnfoldAlways
-	       else calcUnfoldingGuidance True{-sccs OK-} bOMB_OUT_SIZE rhs
-
-    bOMB_OUT_SIZE = case (intSwitchSet chkr SimplUnfoldingCreationThreshold) of
-		      Nothing -> uNFOLDING_CREATION_THRESHOLD
-		      Just xx -> xx
-
-    ok_to_dup     = switchIsOn chkr SimplOkToDupCode
---NO:			|| exprSmallEnoughToDup rhs
---			-- [Andy] added, Jun 95
-
-{- Reinstated AJG Jun 95; This is needed
-    --example that does not (currently) work
-    --without this extention
-
-    --let f = g x
-    --in
-    --  case <exp> of
-    --	   True -> h i f
-    --	   False -> f
-    --	==>
-    --  case <exp> of
-    --	   True -> h i f
-    --	   False -> g x
--}
-{- OLD:
-   Omitted SLPJ Feb 95; should, I claim, be unnecessary
-	-- is_really_small looks for things like f a b c
-	-- but making sure there are not *too* many arguments.
-	-- (This is brought to you by *ANDY* Magic Constants, Inc.)
-    is_really_small
-      = case collectArgs new_rhs of
-	  (Var _, _, _, xs) -> length xs < 10
-	  _ -> False
--}
+    unfolding    = SimpleUnfolding form_summary guidance old_rhs
+    form_summary = mkFormSummary old_rhs
+
+    guidance | not (switchIsSet env IgnoreINLINEPragma) && idWantsToBeINLINEd out_id
+	     = UnfoldAlways
+
+             | otherwise
+	     = calcUnfoldingGuidance True{-sccs OK-} bOMB_OUT_SIZE (unTagBinders old_rhs)
+
+    bOMB_OUT_SIZE = getSimplIntSwitch chkr SimplUnfoldingCreationThreshold
+
+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
+  where
+    new_out_id_env = addToUFM_C modifyOutEnvItem out_id_env out_id 
+				(out_id, occ_info, rhs_info)
 \end{code}
 
-\begin{code}
-lookupUnfolding :: SimplEnv -> Id -> UnfoldingDetails
 
-lookupUnfolding (SimplEnv _ _ _ _ unfold_env) var
-  | not (isLocallyDefined var)	-- Imported, so look inside the id
-  = getIdUnfolding var
+\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)
 
-  | otherwise			-- Locally defined, so look in the envt.
-				-- There'll be nothing inside the Id.
-  = lookup_unfold_env unfold_env var
+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}
 
-We need to remove any @GenForm@ bindings from the UnfoldEnv for
-the RHS of an Id which has an INLINE pragma.
+
+
+%************************************************************************
+%*									*
+\subsubsection{The @ConAppMap@ type}
+%*									*
+%************************************************************************
+
+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}
 
 \begin{code}
-filterUnfoldEnvForInlines :: SimplEnv -> SimplEnv
+nullConApps = emptyFM
 
-filterUnfoldEnvForInlines env@(SimplEnv chkr encl_cc ty_env id_env unfold_env)
-  = SimplEnv chkr encl_cc ty_env id_env new_unfold_env
+extendConApps con_apps id (Con con args)
+  = addToFM_C (\old new -> new++old) con_apps (UCA con val_args) [(ty_args,con)]
   where
-    new_unfold_env = null_unfold_env
-	-- This version is really simple.  INLINEd things are going to
-	-- be inlined wherever they are used, and then all the
-	-- UnfoldEnv stuff will take effect.  Meanwhile, there isn't
-	-- much point in doing anything to the as-yet-un-INLINEd rhs.
-
-	-- 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.
-	--
-	-- So he'd like not to filter the unfold env at all.  But that's a disaster:
-	-- Suppose we have:
-	--
-	-- 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.
+    val_args = filter isValArg args		-- Literals and Ids
+    ty_args  = [ty | TyArg ty <- args]		-- Just types
+
+extendConApps con_apps id other_rhs = con_apps
 \end{code}
 
-======================
+\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
+  where
+    val_args = filter isValArg args		-- Literals and Ids
+    ty_args  = [ty | TyArg ty <- args]		-- Just types
+
+\end{code}
 
-In @lookForConstructor@ we used (before Apr 94) to have a special case
-for nullary constructors:
+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}
+\begin{verbatim}	
   = 	-- Don't re-use nullary constructors; it's a waste.  Consider
 	-- let
 	-- 	  a = leInt#! p q
@@ -852,10 +568,43 @@ for nullary constructors:
     Nothing
 \end{verbatim}
 
-but now we only do constructor re-use in let-bindings the special
-case isn't necessary any more.
+
+The main thing about @UnfoldConApp@ is that it has @Ord@ defined on
+it, so we can use it for a @FiniteMap@ key.
 
 \begin{code}
-lookForConstructor (SimplEnv _ _ _ _ unfold_env) con args
-  = lookup_conapp unfold_env con args
+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
+  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}
+
+
+
diff --git a/ghc/compiler/simplCore/SimplMonad.lhs b/ghc/compiler/simplCore/SimplMonad.lhs
index 9413623554..20662f8921 100644
--- a/ghc/compiler/simplCore/SimplMonad.lhs
+++ b/ghc/compiler/simplCore/SimplMonad.lhs
@@ -26,6 +26,7 @@ IMPORT_1_3(Ix)
 IMPORT_DELOOPER(SmplLoop)		-- well, cheating sort of
 
 import Id		( mkSysLocal, mkIdWithNewUniq )
+import CoreUnfold	( SimpleUnfolding )
 import SimplEnv
 import SrcLoc		( mkUnknownSrcLoc )
 import TyVar		( cloneTyVar )
@@ -126,6 +127,7 @@ data TickType
   | CaseOfError
   | TyBetaReduction
   | BetaReduction
+  | SpecialisationDone
   {- BEGIN F/B ENTRIES -}
   -- the 8 rules
   | FoldrBuild	     	-- foldr f z (build g) ==>
@@ -165,6 +167,9 @@ instance Text TickType where
     showsPrec p CaseOfError	= showString "CaseOfError      "
     showsPrec p TyBetaReduction	= showString "TyBetaReduction  "
     showsPrec p BetaReduction	= showString "BetaReduction    "
+    showsPrec p SpecialisationDone 
+				= showString "Specialisation   "
+
 	-- Foldr/Build Stuff:
     showsPrec p FoldrBuild	= showString "FoldrBuild       "
     showsPrec p FoldrAugment	= showString "FoldrAugment     "
@@ -212,6 +217,7 @@ zeroSimplCount
 	(CaseOfError, 0),
 	(TyBetaReduction,0),
 	(BetaReduction,0),
+	(SpecialisationDone,0),
 	-- Foldr/Build Stuff:
 	(FoldrBuild, 0),
 	(FoldrAugment, 0),
@@ -257,6 +263,8 @@ tick tick_type us (SimplCount n stuff)
 
 tickN :: TickType -> Int -> SmplM ()
 
+tickN tick_type 0 us counts 
+  = ((), counts)
 tickN tick_type IBOX(increment) us (SimplCount n stuff)
   = ((), SimplCount (n _ADD_ increment)
 #ifdef OMIT_SIMPL_COUNTS
diff --git a/ghc/compiler/simplCore/SimplPgm.lhs b/ghc/compiler/simplCore/SimplPgm.lhs
index 8786a69e2f..a2d2797cb4 100644
--- a/ghc/compiler/simplCore/SimplPgm.lhs
+++ b/ghc/compiler/simplCore/SimplPgm.lhs
@@ -11,9 +11,10 @@ module SimplPgm ( simplifyPgm ) where
 IMP_Ubiq(){-uitous-}
 
 import CmdLineOpts	( opt_D_verbose_core2core,
-			  switchIsOn, intSwitchSet, SimplifierSwitch(..)
+			  switchIsOn, SimplifierSwitch(..)
 			)
 import CoreSyn
+import CoreUnfold	( SimpleUnfolding )
 import CoreUtils	( substCoreExpr )
 import Id		( externallyVisibleId,
 			  mkIdEnv, lookupIdEnv, SYN_IE(IdEnv),
@@ -50,10 +51,7 @@ simplifyPgm binds s_sw_chkr simpl_stats us
 
     occur_anal = occurAnalyseBinds
 
-    max_simpl_iterations
-      = case (intSwitchSet s_sw_chkr MaxSimplifierIterations) of
-	  Nothing  -> 1    -- default
-	  Just max -> max
+    max_simpl_iterations = getSimplIntSwitch s_sw_chkr MaxSimplifierIterations
 
     simpl_pgm :: Int -> Int -> [CoreBinding] -> SmplM ([CoreBinding], Int, SimplCount)
 
diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs
index 70ed4b8079..fa14e39a33 100644
--- a/ghc/compiler/simplCore/SimplUtils.lhs
+++ b/ghc/compiler/simplCore/SimplUtils.lhs
@@ -27,7 +27,7 @@ IMPORT_DELOOPER(SmplLoop)		-- paranoia checking
 import BinderInfo
 import CmdLineOpts	( SimplifierSwitch(..) )
 import CoreSyn
-import CoreUtils	( manifestlyWHNF )
+import CoreUnfold	( SimpleUnfolding, mkFormSummary, FormSummary(..) )
 import Id		( idType, isBottomingId, idWantsToBeINLINEd, dataConArgTys,
 			  getIdArity, GenId{-instance Eq-}
 			)
@@ -76,8 +76,11 @@ floatExposesHNF float_lets float_primops ok_to_dup rhs
     try (App (App (Var bld) _) _)	  | bld == buildId   = True
     try (App (App (App (Var aug) _) _) _) | aug == augmentId = True
 
-    try other = manifestlyWHNF other
-	{- but *not* necessarily "manifestlyBottom other"...
+    try other = case mkFormSummary other of
+			VarForm   -> True
+			ValueForm -> True
+			other	  -> False
+	{- but *not* necessarily "BottomForm"...
 
 	   We may want to float a let out of a let to expose WHNFs,
 	    but to do that to expose a "bottom" is a Bad Idea:
diff --git a/ghc/compiler/simplCore/SimplVar.lhs b/ghc/compiler/simplCore/SimplVar.lhs
index 03401ce5d6..4e4ef5582a 100644
--- a/ghc/compiler/simplCore/SimplVar.lhs
+++ b/ghc/compiler/simplCore/SimplVar.lhs
@@ -7,8 +7,7 @@
 #include "HsVersions.h"
 
 module SimplVar (
-	completeVar,
-	leastItCouldCost
+	completeVar
     ) where
 
 IMP_Ubiq(){-uitous-}
@@ -17,14 +16,18 @@ IMPORT_DELOOPER(SmplLoop)		( simplExpr )
 import CgCompInfo	( uNFOLDING_USE_THRESHOLD,
 			  uNFOLDING_CON_DISCOUNT_WEIGHT
 			)
-import CmdLineOpts	( intSwitchSet, switchIsOn, SimplifierSwitch(..) )
+import CmdLineOpts	( switchIsOn, SimplifierSwitch(..) )
 import CoreSyn
-import CoreUnfold	( whnfDetails, UnfoldingDetails(..), UnfoldingGuidance(..),
-			  FormSummary(..)
-			)
-import Id		( idType, getIdInfo,
+import CoreUnfold	( Unfolding(..), UnfoldingGuidance(..), SimpleUnfolding(..),
+			  FormSummary,
+			  smallEnoughToInline )
+import BinderInfo	( BinderInfo, noBinderInfo, okToInline )
+
+import CostCentre	( CostCentre, noCostCentreAttached )
+import Id		( idType, getIdInfo, getIdUnfolding, getIdSpecialisation,
 			  GenId{-instance Outputable-}
 			)
+import SpecEnv		( SpecEnv, lookupSpecEnv )
 import IdInfo		( DeforestInfo(..) )
 import Literal		( isNoRepLit )
 import MagicUFs		( applyMagicUnfoldingFun, MagicUnfoldingFun )
@@ -36,6 +39,7 @@ import SimplMonad
 import TyCon		( tyConFamilySize )
 import Type		( isPrimType, getAppDataTyConExpandingDicts, maybeAppDataTyConExpandingDicts )
 import Util		( pprTrace, assertPanic, panic )
+import Maybes		( maybeToBool )
 \end{code}
 
 %************************************************************************
@@ -46,289 +50,93 @@ import Util		( pprTrace, assertPanic, panic )
 
 This where all the heavy-duty unfolding stuff comes into its own.
 
-
+\begin{code}
 completeVar env var args
-  | has_magic_unfolding
+
+  | maybeToBool maybe_magic_result
   = tick MagicUnfold	`thenSmpl_`
-    doMagicUnfold
+    magic_result
 
-  | has_unfolding && ok_to_inline
+  | not do_deforest &&
+    maybeToBool maybe_unfolding_info &&
+    (always_inline || (ok_to_inline && not essential_unfoldings_only)) && 
+    costCentreOk (getEnclosingCC env) (getEnclosingCC unfold_env)
   = tick UnfoldingDone	`thenSmpl_`
-    simplExpr env the_unfolding args
+    simplExpr unfold_env unf_template args
 
-  | has_specialisation
+  | maybeToBool maybe_specialisation
   = tick SpecialisationDone	`thenSmpl_`
     simplExpr (extendTyEnvList env spec_bindings) 
-	      the_specialisation 
-	      remaining_args
-
-  | otherwise
-  = mkGenApp (Var var) args
-
-  where
-    unfolding = lookupUnfolding env var
-
-    (has_magic_unfolding, do_magic_unfold)
-	= case unfolding of
-	    MagicForm str magic_fn
-		   
-\begin{code}
-completeVar :: SimplEnv -> OutId -> [OutArg] -> SmplM OutExpr
-
-completeVar env var args
-  = let
-	boring_result = mkGenApp (Var var) args
-    in
-    case (lookupUnfolding env var) of
-
-      GenForm form_summary template guidance
-	-> considerUnfolding env var args
-			     (False{-ToDo:!-}{-txt_occ-}) form_summary template guidance
-
-      MagicForm str magic_fun
-	->  applyMagicUnfoldingFun magic_fun env args `thenSmpl` \ result ->
-	    case result of
-	      Nothing	        -> returnSmpl boring_result
-	      Just magic_result ->
-		{- pprTrace "MagicForm:- " (ppAbove
-			(ppBesides [
-			   ppr PprDebug var,
-			   ppr PprDebug args])
-			(ppBesides [
-				ppStr "AFTER    :- ",
-			   ppr PprDebug magic_result])) (returnSmpl ()) `thenSmpl` \ () ->
-		-}
-		tick MagicUnfold		`thenSmpl_`
-		returnSmpl magic_result
-
--- LATER:
---    IWantToBeINLINEd _ -> returnSmpl boring_result
-
-      other -> returnSmpl boring_result
-\end{code}
-
-
-%************************************************************************
-%*									*
-\subsection[considerUnfolding]{Given all the info, do (not) do the unfolding}
-%*									*
-%************************************************************************
-
-We have very limited information about an unfolding expression: (1)~so
-many type arguments and so many value arguments expected---for our
-purposes here, we assume we've got those.  (2)~A ``size'' or ``cost,''
-a single integer.  (3)~An ``argument info'' vector.  For this, what we
-have at the moment is a Boolean per argument position that says, ``I
-will look with great favour on an explicit constructor in this
-position.''
-
-Assuming we have enough type- and value arguments (if not, we give up
-immediately), then we see if the ``discounted size'' is below some
-(semi-arbitrary) threshold.  It works like this: for every argument
-position where we're looking for a constructor AND WE HAVE ONE in our
-hands, we get a (again, semi-arbitrary) discount [proportion to the
-number of constructors in the type being scrutinized].
-
-\begin{code}
-considerUnfolding
-	:: SimplEnv
-	-> OutId		-- Id we're thinking about
-	-> [OutArg]		-- Applied to these
-	-> Bool			-- If True then *always* inline,
-				-- because it's the only one
-	-> FormSummary
-	-> InExpr		-- Template for unfolding;
-	-> UnfoldingGuidance	-- To help us decide...
-	-> SmplM CoreExpr	-- Result!
-
-considerUnfolding env var args txt_occ form_summary template guidance
-  | switchIsOn sw_chkr EssentialUnfoldingsOnly
-  = dont_go_for_it -- we're probably in a hurry in this simpl round...
-
-  | do_deforest
-  = pprTrace "" (ppBesides [ppStr "not attempting to unfold `",
-				    ppr PprDebug var,
-				    ppStr "' due to DEFOREST pragma"])
-			dont_go_for_it
-
-  | txt_occ
-  = go_for_it
-
-  | (case form_summary of {BottomForm -> True; other -> False} &&
-    not (any isPrimType [ ty | (TyArg ty) <- args ]))
-		-- Always inline bottoming applications, unless
-		-- there's a primitive type lurking around...
-  = go_for_it
+	      spec_template
+	      (map TyArg leftover_ty_args ++ remaining_args)
 
   | otherwise
-  =
-    -- If this is a deforestable Id, then don't unfold it (the deforester
-    -- will do it).
-
-    case getInfo (getIdInfo var) of {
-       DoDeforest -> pprTrace "" (ppBesides [ppStr "not unfolding `",
-				    ppr PprDebug var,
-				    ppStr "' due to DEFOREST pragma"])
-			dont_go_for_it;
-       Don'tDeforest ->
-
-    case guidance of
-      UnfoldNever  -> dont_go_for_it
-
-      UnfoldAlways -> go_for_it
-
-      EssentialUnfolding -> go_for_it
-
-      UnfoldIfGoodArgs m_tys_wanted n_vals_wanted is_con_vec size
-	-> if m_tys_wanted > no_tyargs
-	   || n_vals_wanted > no_valargs then
-	      --pprTrace "dont_go_for_it1:" (ppAbove (ppr PprDebug guidance) (ppr PprDebug var))
-	      dont_go_for_it
-
-	   else if n_vals_wanted == 0
-		&& rhs_looks_like_a_Con then
-	      -- we are very keen on inlining data values
-	      -- (see comments elsewhere); we ignore any size issues!
-	      go_for_it
+  = returnSmpl (mkGenApp (Var var) args)
 
-	   else -- we try the fun stuff
-	      let
-		  discounted_size
-		    = discountedCost env con_discount size no_valargs is_con_vec valargs
-	      in
-	      if discounted_size <= unfold_use_threshold then
-		  go_for_it
-	      else
-		  --pprTrace "dont_go_for_it2:" (ppCat [ppr PprDebug var, ppInt size, ppInt discounted_size, ppInt unfold_use_threshold, ppr PprDebug guidance])
-		  dont_go_for_it
-    }
   where
-    sw_chkr = getSwitchChecker env
-
-    unfold_use_threshold
-      = case (intSwitchSet sw_chkr SimplUnfoldingUseThreshold) of
-	  Nothing -> uNFOLDING_USE_THRESHOLD
-	  Just xx -> xx
-
-    con_discount  -- ToDo: ************ get from a switch *********
-      = uNFOLDING_CON_DISCOUNT_WEIGHT
-
-    (_, _, tyargs, valargs) = collectArgs args_in_dummy_expr
-    no_tyargs  = length tyargs
-    no_valargs = length valargs
-    args_in_dummy_expr = mkGenApp (Var (panic "SimplVar.dummy")) args
-    -- we concoct this dummy expr, just so we can use collectArgs
-    -- (rather than make up a special-purpose bit of code)
-
-    rhs_looks_like_a_Con
-      = let
-	    (_,_,val_binders,body) = collectBinders template
-    	in
-    	case (val_binders, body) of
-    	  ([], Con _ _) -> True
-	  other -> False
-
-    dont_go_for_it = returnSmpl (mkGenApp (Var var) args)
-
-    go_for_it      = --pprTrace "unfolding:" (ppCat [ppr PprDebug var, ppChar ':', ppr PprDebug template]) (
-		     tick UnfoldingDone		`thenSmpl_`
-		     simplExpr env template args
-		     --)
+    unfolding_from_id = getIdUnfolding var
+
+	---------- Magic unfolding stuff
+    maybe_magic_result	= case unfolding_from_id of
+				MagicUnfolding _ magic_fn -> applyMagicUnfoldingFun magic_fn 
+										    env args
+			        other 			  -> Nothing
+    (Just magic_result)	= maybe_magic_result
+
+	---------- Unfolding stuff
+    maybe_unfolding_info 
+	= case (lookupOutIdEnv env var, unfolding_from_id) of
+	     (Just (_, occ_info, OutUnfolding enc_cc unf), _)
+		-> Just (occ_info, setEnclosingCC env enc_cc, unf)	
+	     (Just (_, occ_info, InUnfolding env_unf unf), _)
+		-> Just (occ_info, combineSimplEnv env env_unf, unf)	
+	     (_, CoreUnfolding unf)
+		-> Just (noBinderInfo, env, unf)
+
+	     other -> Nothing
+
+    Just (occ_info, unfold_env, simple_unfolding)     = maybe_unfolding_info
+    SimpleUnfolding form guidance unf_template = simple_unfolding
+
+	---------- Specialisation stuff
+    (ty_args, remaining_args) = initialTyArgs args
+    maybe_specialisation = lookupSpecEnv (getIdSpecialisation var) ty_args
+    (Just (spec_template, (spec_bindings, leftover_ty_args))) = maybe_specialisation
+
+
+	---------- Switches
+    sw_chkr		      = getSwitchChecker env
+    essential_unfoldings_only = switchIsOn sw_chkr EssentialUnfoldingsOnly
+    always_inline	      = case guidance of {UnfoldAlways -> True; other -> False}
+    ok_to_inline	      = okToInline form 
+			      		   occ_info
+			      		   small_enough
+    small_enough = smallEnoughToInline con_disc unf_thresh arg_evals guidance
+    arg_evals = [is_evald arg | arg <- args, isValArg arg]
+  
+    is_evald (VarArg v) = isEvaluated (lookupRhsInfo env v)
+    is_evald (LitArg l) = True
+
+    con_disc   = getSimplIntSwitch sw_chkr SimplUnfoldingConDiscount
+    unf_thresh = getSimplIntSwitch sw_chkr SimplUnfoldingUseThreshold
 
 #if OMIT_DEFORESTER
     do_deforest = False
 #else
     do_deforest = case (getInfo (getIdInfo var)) of { DoDeforest -> True; _ -> False }
 #endif
-\end{code}
 
-\begin{code}
-type ArgInfoVector = [Bool]
-
-discountedCost
-	:: SimplEnv	    -- so we can look up things about the args
-	-> Int		    -- the discount for a "constructor" hit;
-			    -- we multiply by the # of cons in the type.
-	-> Int		    -- the size/cost of the expr
-	-> Int		    -- the number of val args (== length args)
-	-> ArgInfoVector    -- what we know about the *use* of the arguments
-	-> [OutArg]	    -- *an actual set of value arguments*!
-	-> Int
-
-    -- If we apply an expression (usually a function) of given "costs"
-    -- to a particular set of arguments (possibly none), what will
-    -- the resulting expression "cost"?
-
-discountedCost env con_discount_weight size no_args is_con_vec args
-  = ASSERT(no_args == length args)
-    disc (size - no_args) is_con_vec args
-	-- we start w/ a "discount" equal to the # of args...
-  where
-    disc size [] _ = size
-    disc size _ [] = size
-
-    disc size (want_con_here:want_cons) (arg:rest_args)
-      = let
-	    full_price	         = disc size
-	    take_something_off v = let
-				     (tycon, _, _) = getAppDataTyConExpandingDicts (idType v)
-				     no_cons = tyConFamilySize tycon
-				     reduced_size
-				       = size - (no_cons * con_discount_weight)
-				   in
-				   disc reduced_size
-	in
-	(if not want_con_here then
-	    full_price
-	else
-	    case arg of
-	      LitArg _ 					     -> full_price
-	      VarArg v | whnfDetails (lookupUnfolding env v) -> take_something_off v
-		       | otherwise			     -> full_price
 
-	) want_cons rest_args
-\end{code}
+-- costCentreOk checks that it's ok to inline this thing
+-- The time it *isn't* is this:
+--
+--	f x = let y = E in
+--	      scc "foo" (...y...)
+--
+-- Here y has a subsumed cost centre, and we can't inline it inside "foo",
+-- regardless of whether E is a WHNF or not.
 
-We use this one to avoid exporting inlinings that we ``couldn't possibly
-use'' on the other side.  Can be overridden w/ flaggery.
-\begin{code}
-leastItCouldCost
-	:: Int
-	-> Int		    -- the size/cost of the expr
-	-> Int		    -- number of value args
-	-> ArgInfoVector    -- what we know about the *use* of the arguments
-	-> [Type]	    -- NB: actual arguments *not* looked at;
-			    -- but we know their types
-	-> Int
-
-leastItCouldCost con_discount_weight size no_val_args is_con_vec arg_tys
-  = ASSERT(no_val_args == length arg_tys)
-    disc (size - no_val_args) is_con_vec arg_tys
-	-- we start w/ a "discount" equal to the # of args...
-  where
-    -- ToDo: rather sad that this isn't commoned-up w/ the one above...
-
-    disc size [] _ = size
-    disc size _ [] = size
-
-    disc size (want_con_here:want_cons) (arg_ty:rest_arg_tys)
-      = let
-	    take_something_off tycon
-	      = let
-		    no_cons = tyConFamilySize tycon
-
-		    reduced_size
-		      = size - (no_cons * con_discount_weight)
-		in
-		reduced_size
-	in
-	if not want_con_here then
-	    disc size want_cons rest_arg_tys
-	else
-	    case (maybeAppDataTyConExpandingDicts arg_ty, isPrimType arg_ty) of
-	      (Just (tycon, _, _), False) ->
-		disc (take_something_off tycon) want_cons rest_arg_tys
-
-	      other -> disc size want_cons rest_arg_tys
-\end{code}
+costCentreOk cc_encl cc_rhs
+  = noCostCentreAttached cc_encl || not (noCostCentreAttached cc_rhs)
+\end{code}		   
 
diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs
index a6e44d3fb4..5f00a8e9e7 100644
--- a/ghc/compiler/simplCore/Simplify.lhs
+++ b/ghc/compiler/simplCore/Simplify.lhs
@@ -15,11 +15,11 @@ IMPORT_1_3(List(partition))
 import BinderInfo
 import CmdLineOpts	( SimplifierSwitch(..) )
 import ConFold		( completePrim )
+import CoreUnfold	( Unfolding, SimpleUnfolding, mkFormSummary, FormSummary(..) )
 import CostCentre 	( isSccCountCostCentre, cmpCostCentre )
 import CoreSyn
 import CoreUtils	( coreExprType, nonErrorRHSs, maybeErrorApp,
-			  unTagBinders, squashableDictishCcExpr,
-			  manifestlyWHNF
+			  unTagBinders, squashableDictishCcExpr
 			)
 import Id		( idType, idWantsToBeINLINEd,
 			  getIdDemandInfo, addIdDemandInfo,
@@ -107,9 +107,9 @@ binding altogether.
 
 2.  Conditional.  In all other situations, the simplifer simplifies
 the RHS anyway, and keeps the new binding.  It also binds the new
-(cloned) variable to a ``suitable'' UnfoldingDetails in the UnfoldEnv.
+(cloned) variable to a ``suitable'' Unfolding in the UnfoldEnv.
 
-Here, ``suitable'' might mean NoUnfoldingDetails (if the occurrence
+Here, ``suitable'' might mean NoUnfolding (if the occurrence
 info is ManyOcc and the RHS is not a manifest HNF, or UnfoldAlways (if
 the variable has an INLINE pragma on it).  The idea is that anything
 in the UnfoldEnv is safe to use, but also has an enclosing binding if
@@ -156,7 +156,7 @@ because then we'd duplicate BIG when we inline'd y.  (Exception:
 things in the UnfoldEnv with UnfoldAlways flags, which originated in
 other INLINE pragmas.)
 
-So, we clean out the UnfoldEnv of all GenForm inlinings before
+So, we clean out the UnfoldEnv of all SimpleUnfolding inlinings before
 going into such an RHS.
 
 What about imports?  They don't really matter much because we only
@@ -190,36 +190,20 @@ simplTopBinds env [] = returnSmpl []
 
 -- Dead code is now discarded by the occurrence analyser,
 
-simplTopBinds env (NonRec binder@(in_id, occ_info) rhs : binds)
-  | inlineUnconditionally ok_to_dup_code occ_info
-  = let
-	new_env = extendIdEnvWithInlining env env binder rhs
-    in
-    simplTopBinds new_env binds
-  where
-    ok_to_dup_code = switchIsSet env SimplOkToDupCode
-
 simplTopBinds env (NonRec binder@(in_id,occ_info) rhs : binds)
   = 	-- No cloning necessary at top level
  	-- Process the binding
-    simplRhsExpr env binder rhs		`thenSmpl` \ rhs' ->
-    let
-       new_env = case rhs' of
-	 Var v			    -> extendIdEnvWithAtom env binder (VarArg v)
-	 Lit i | not (isNoRepLit i) -> extendIdEnvWithAtom env binder (LitArg i)
-	 other			    -> extendUnfoldEnvGivenRhs env binder in_id rhs'
-    in
+    simplRhsExpr env binder rhs 	`thenSmpl` \ rhs' ->
+    completeNonRec env binder rhs'	`thenSmpl` \ (new_env, binds1') ->
+
 	-- Process the other bindings
-    simplTopBinds new_env binds	`thenSmpl` \ binds' ->
+    simplTopBinds new_env binds	`thenSmpl` \ binds2' ->
 
 	-- Glue together and return ...
-	-- We leave it to susequent occurrence analysis to throw away
-	-- an unused atom binding. This localises the decision about
-	-- discarding top-level bindings.
-    returnSmpl (NonRec in_id rhs' : binds')
+    returnSmpl (binds1' ++ binds2')
 
 simplTopBinds env (Rec pairs : binds)
-  = simplRecursiveGroup env triples 	`thenSmpl` \ (bind', new_env) ->
+  = simplRecursiveGroup env ids pairs 	`thenSmpl` \ (bind', new_env) ->
 
 	-- Process the other bindings
     simplTopBinds new_env binds		`thenSmpl` \ binds' ->
@@ -227,8 +211,7 @@ simplTopBinds env (Rec pairs : binds)
 	-- Glue together and return
     returnSmpl (bind' : binds')
   where
-    triples = [(id, (binder, rhs)) | (binder@(id,_), rhs) <- pairs]
-		-- No cloning necessary at top level
+    ids = [id | (binder@(id,_), rhs) <- pairs]	-- No cloning necessary at top level
 \end{code}
 
 %************************************************************************
@@ -256,26 +239,15 @@ the more sophisticated stuff.
 \begin{code}
 simplExpr env (Var v) args
   = case (lookupId env v) of
-      Nothing -> let
-		    new_v = simplTyInId env v
-		 in
-		 completeVar env new_v args
-
-      Just info ->
-	case info of
-    	  ItsAnAtom (LitArg lit) 	-- A boring old literal
-			-- Paranoia check for args empty
-	    ->	case args of
-		  []    -> returnSmpl (Lit lit)
-		  other -> panic "simplExpr:coVar"
-
-	  ItsAnAtom (VarArg var) 	-- More interesting!  An id!
-					-- No need to substitute the type env here,
-					-- because we already have!
-	    -> completeVar env var args
-
-	  InlineIt id_env ty_env in_expr 	-- A macro-expansion
-	    -> simplExpr (replaceInEnvs env (ty_env, id_env)) in_expr args
+      LitArg lit		-- A boring old literal
+	-> ASSERT( null args )
+	   returnSmpl (Lit lit)
+
+      VarArg var 	-- More interesting!  An id!
+	-> completeVar env var args
+	 			-- Either Id is in the local envt, or it's a global.
+				-- In either case we don't need to apply the type
+				-- environment to it.
 \end{code}
 
 Literals
@@ -346,11 +318,8 @@ we can pass them all to @mkTyLamTryingEta@.
 \begin{code}
 simplExpr env (Lam (TyBinder tyvar) body) (TyArg ty : args)
   = -- ASSERT(not (isPrimType ty))
-    let
-	new_env = extendTyEnv env tyvar ty
-    in
     tick TyBetaReduction	`thenSmpl_`
-    simplExpr new_env body args
+    simplExpr (extendTyEnv env tyvar ty) body args
 
 simplExpr env tylam@(Lam (TyBinder tyvar) body) []
   = do_tylambdas env [] tylam
@@ -381,63 +350,37 @@ simplExpr env (Lam (TyBinder _) _) (_ : _)
 Ordinary lambdas
 ~~~~~~~~~~~~~~~~
 
-\begin{code}
-simplExpr env (Lam (ValBinder binder) body) args
-  | null leftover_binders
-  = 	-- The lambda is saturated (or over-saturated)
-    tick BetaReduction	`thenSmpl_`
-    simplExpr env_for_enough_args body leftover_args
-
-  | otherwise
-  = 	-- Too few args to saturate the lambda
-    ASSERT( null leftover_args )
+There's a complication with lambdas that aren't saturated.
+Suppose we have:
 
-    (if not (null args) -- ah, we must've gotten rid of some...
-     then tick BetaReduction
-     else returnSmpl (panic "BetaReduction")
-    ) `thenSmpl_`
+	(\x. \y. ...x...)
 
-    simplLam env_for_too_few_args leftover_binders body
-	     0 {- Guaranteed applied to at least 0 args! -}
+If we did nothing, x is used inside the \y, so would be marked
+as dangerous to dup.  But in the common case where the abstraction
+is applied to two arguments this is over-pessimistic.
+So instead we don't take account of the \y when dealing with x's usage;
+instead, the simplifier is careful when partially applying lambdas.
 
+\begin{code}
+simplExpr env expr@(Lam (ValBinder binder) body) orig_args
+  = go 0 env expr orig_args
   where
-    (binder_args_pairs, leftover_binders, leftover_args) = collect_val_args binder args
-
-    env_for_enough_args  = extendIdEnvWithAtomList env binder_args_pairs
-
-    env_for_too_few_args = extendIdEnvWithAtomList env zapped_binder_args_pairs
-
-	-- Since there aren't enough args the binders we are cancelling with
-	-- the args supplied are, in effect, ocurring inside a lambda.
-	-- So we modify their occurrence info to reflect this fact.
-	-- Example:	(\ x y z -> e) p q
-	--	    ==> (\z -> e[p/x, q/y])
-	-- 	but we should behave as if x and y are marked "inside lambda".
-	-- The occurrence analyser does not mark them so itself because then we
-	-- do badly on the very common case of saturated lambdas applications:
-	--		(\ x y z -> e) p q r
-	--	    ==> e[p/x, q/y, r/z]
-	--
-    zapped_binder_args_pairs = [ ((id, markDangerousToDup occ_info), arg)
-			       | ((id, occ_info), arg) <- binder_args_pairs ]
-
-    collect_val_args :: InBinder	    	-- Binder
- 		     -> [OutArg]	    	-- Arguments
-		     -> ([(InBinder,OutArg)],	-- Binder,arg pairs (ToDo: a maybe?)
-			 [InBinder],	    	-- Leftover binders (ToDo: a maybe)
-			 [OutArg])	    	-- Leftover args
-
-	-- collect_val_args strips off the leading ValArgs from
-	-- the current arg list, returning them along with the
-	-- depleted list
-    collect_val_args binder []   = ([], [binder], [])
-    collect_val_args binder (arg : args) | isValArg arg
-	= ([(binder,arg)], [], args)
-
-#ifdef DEBUG
-    collect_val_args _ (other_val_arg : _) = panic "collect_val_args"
-		-- TyArg should never meet a Lam
-#endif
+    go n env (Lam (ValBinder binder) body) (val_arg : args)
+      | isValArg val_arg		-- The lambda has an argument
+      = tick BetaReduction	`thenSmpl_`
+        go (n+1) (extendIdEnvWithAtom env binder val_arg) body args
+
+    go n env expr@(Lam (ValBinder binder) body) args
+      	-- The lambda is un-saturated, so we must zap the occurrence info
+ 	-- on the arguments we've already beta-reduced into the body of the lambda
+      = ASSERT( null args )	-- Value lambda must match value argument!
+        let
+	    new_env = markDangerousOccs env (take n orig_args)
+        in
+        simplValLam new_env expr 0 {- Guaranteed applied to at least 0 args! -}
+
+    go n env non_val_lam_expr args     	-- The lambda had enough arguments
+      = simplExpr env non_val_lam_expr args
 \end{code}
 
 
@@ -446,19 +389,6 @@ Let expressions
 
 \begin{code}
 simplExpr env (Let bind body) args
-
-{- OMIT this; it's a pain to do at the other sites wehre simplBind is called,
-   and it doesn't seem worth retaining the ability to not float applications
-   into let/case 
-
-  | switchIsSet env SimplNoLetFromApp
-  = simplBind env bind (\env -> simplExpr env body [])
-		       (computeResultType env body [])	`thenSmpl` \ let_expr' ->
-    returnSmpl (mkGenApp let_expr' args)
-
-  | otherwise		-- No float from application
--}
-
   = simplBind env bind (\env -> simplExpr env body args)
 		       (computeResultType env body args)
 \end{code}
@@ -527,7 +457,7 @@ This moves the cost of doing the application inside the scc
 \begin{code}
 simplExpr env (SCC cost_centre body) args
   = let
-	new_env = setEnclosingCC env (EnclosingCC cost_centre)
+	new_env = setEnclosingCC env cost_centre
     in
     simplExpr new_env body args		`thenSmpl` \ body' ->
     returnSmpl (SCC cost_centre body')
@@ -564,14 +494,16 @@ simplRhsExpr env binder@(id,occ_info) rhs
 
   | otherwise	-- Have a go at eta expansion
   = 	-- Deal with the big lambda part
+    ASSERT( null uvars )	-- For now
+
     mapSmpl cloneTyVarSmpl tyvars			`thenSmpl` \ tyvars' ->
     let
 	lam_env  = extendTyEnvList rhs_env (zipEqual "simplRhsExpr" tyvars (mkTyVarTys tyvars'))
     in
 	-- Deal with the little lambda part
-	-- Note that we call simplLam even if there are no binders, in case
-	-- it can do arity expansion.
-    simplLam lam_env binders body min_no_of_args	`thenSmpl` \ lambda' ->
+	-- Note that we call simplLam even if there are no binders,
+	-- in case it can do arity expansion.
+    simplValLam lam_env body (getBinderInfoArity occ_info)	`thenSmpl` \ lambda' ->
 
 	-- Put it back together
     returnSmpl (
@@ -580,21 +512,38 @@ simplRhsExpr env binder@(id,occ_info) rhs
        else mkTyLam) tyvars' lambda'
     )
   where
-	-- Note from ANDY:
-	-- If you say {-# INLINE #-} then you get what's coming to you;
-	-- you are saying inline the rhs, please.
-	-- we might want a {-# INLINE UNSIMPLIFIED #-} option.
-    rhs_env | simplIdWantsToBeINLINEd id env = filterUnfoldEnvForInlines env
-	    | otherwise			     = env
 
-    (uvars, tyvars, binders, body) = collectBinders rhs
+    rhs_env | not (switchIsSet env IgnoreINLINEPragma) &&
+	      idWantsToBeINLINEd id
+	    = switchOffInlining env
+	    | otherwise	
+            = env
+
+	-- Switch off all inlining in the RHS of things that have an INLINE pragma.
+	-- They are 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.
+	-- It's very important to switch off inlining!  Consider:
+	--
+	-- 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.
 
-    min_no_of_args | not (null binders)			&& 	-- It's not a thunk
-		     switchIsSet env SimplDoArityExpand	 	-- Arity expansion on
-		   = getBinderInfoArity occ_info - length binders
+	-- 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!
 
-		   | otherwise	-- Not a thunk
-		   = 0		-- Play safe!
+    (uvars, tyvars, body) = collectUsageAndTyBinders rhs
 
 	-- dont_eta_expand prevents eta expansion in silly situations.
 	-- For example, consider the defn
@@ -627,10 +576,11 @@ Simplify (\binders -> body) trying eta expansion and reduction, given that
 the abstraction will always be applied to at least min_no_of_args.
 
 \begin{code}
-simplLam env binders body min_no_of_args
+simplValLam env expr min_no_of_args
   | not (switchIsSet env SimplDoLambdaEtaExpansion) ||	-- Bale out if eta expansion off
+    null binders				    ||  -- or it's a thunk
     null potential_extra_binder_tys		    ||	-- or ain't a function
-    no_of_extra_binders == 0				-- or no extra binders needed
+    no_of_extra_binders <= 0				-- or no extra binders needed
   = cloneIds env binders		`thenSmpl` \ binders' ->
     let
 	new_env = extendIdEnvWithClones env binders binders'
@@ -657,9 +607,10 @@ simplLam env binders body min_no_of_args
     )
 
   where
+    (binders,body) = collectValBinders expr
     (potential_extra_binder_tys, res_ty)
 	= splitFunTy (simplTy env (coreExprType (unTagBinders body)))
-	-- Note: it's possible that simplLam will be applied to something
+	-- Note: it's possible that simplValLam will be applied to something
 	-- with a forall type.  Eg when being applied to the rhs of
 	--		let x = wurble
 	-- where wurble has a forall-type, but no big lambdas at the top.
@@ -669,7 +620,7 @@ simplLam env binders body min_no_of_args
 
     no_of_extra_binders =	-- First, use the info about how many args it's
 				-- always applied to in its scope
-			   min_no_of_args
+			   (min_no_of_args - length binders)
 
 				-- Next, try seeing if there's a lambda hidden inside
 				-- something cheap
@@ -713,7 +664,6 @@ simplCoerce env coercion ty expr args
 
 	-- Try cancellation; we do this "on the way up" because
 	-- I think that's where it'll bite best
-    mkCoerce (CoerceIn  con1) ty1 (Coerce (CoerceOut con2) ty2 body) | con1 == con2 = body
     mkCoerce (CoerceOut con1) ty1 (Coerce (CoerceIn  con2) ty2 body) | con1 == con2 = body
     mkCoerce coercion ty  body = Coerce coercion ty body
 \end{code}
@@ -777,77 +727,50 @@ ToDo: check this is OK with andy
 -- Dead code is now discarded by the occurrence analyser,
 
 simplBind env (NonRec binder@(id,occ_info) rhs) body_c body_ty
-  |  inlineUnconditionally ok_to_dup occ_info
-  = body_c (extendIdEnvWithInlining env env binder rhs)
-
--- Try let-to-case
--- It's important to try let-to-case before floating. Consider
---
---	let a*::Int = case v of {p1->e1; p2->e2}
---	in b
---
--- (The * means that a is sure to be demanded.)
--- If we do case-floating first we get this:
---
---	let k = \a* -> b
---	in case v of
---		p1-> let a*=e1 in k a
---		p2-> let a*=e2 in k a
---
--- Now watch what happens if we do let-to-case first:
---
---	case (case v of {p1->e1; p2->e2}) of
---	  Int a# -> let a*=I# a# in b
--- ===>
---	let k = \a# -> let a*=I# a# in b
---	in case v of
---		p1 -> case e1 of I# a# -> k a#
---		p1 -> case e1 of I# a# -> k a#
---
--- The latter is clearly better.  (Remember the reboxing let-decl
--- for a is likely to go away, because after all b is strict in a.)
-
-  | will_be_demanded &&
-    try_let_to_case &&
-    type_ok_for_let_to_case rhs_ty &&
-    not (manifestlyWHNF rhs)
-	-- note: no "manifestlyBottom rhs" in there... (comment below)
-    = tick Let2Case				`thenSmpl_`
-      mkIdentityAlts rhs_ty			`thenSmpl` \ id_alts ->
-      simplCase env rhs id_alts (\env rhs -> done_float env rhs body_c) body_ty
-	{-
-	We do not do let to case for WHNFs, e.g.
-
-	  let x = a:b in ...
-	  =/=>
-	  case a:b of x in ...
-
-	  as this is less efficient.
-	  but we don't mind doing let-to-case for "bottom", as that
-	  will
-	  allow us to remove more dead code, if anything:
-	  let x = error in ...
-	  ===>
-	  case error  of x -> ...
-	  ===>
-	  error
+  = simpl_bind env rhs
+  where
+    -- Try let-to-case; see notes below about let-to-case
+    simpl_bind env rhs | will_be_demanded &&
+		         try_let_to_case &&
+		         type_ok_for_let_to_case rhs_ty &&
+			 rhs_is_whnf	-- note: WHNF, but not bottom,  (comment below)
+      = tick Let2Case				`thenSmpl_`
+        mkIdentityAlts rhs_ty			`thenSmpl` \ id_alts ->
+        simplCase env rhs id_alts (\env rhs -> simpl_bind env rhs) body_ty
+
+    -- Try let-from-let
+    simpl_bind env (Let bind rhs) | let_floating_ok
+      = tick LetFloatFromLet                    `thenSmpl_`
+	simplBind env (fix_up_demandedness will_be_demanded bind)
+		      (\env -> simpl_bind env rhs) body_ty
 
-	  Notice that let to case occurs only if x is used strictly in
-	  its body (obviously).
-	-}
+    -- Try case-from-let; this deals with a strict let of error too
+    simpl_bind env (Case scrut alts) | will_be_demanded || 
+				       (float_primops && is_cheap_prim_app scrut)
+      = tick CaseFloatFromLet				`thenSmpl_`
 
-  | (will_be_demanded && not no_float) ||
-    always_float_let_from_let ||
-    floatExposesHNF float_lets float_primops ok_to_dup rhs
-  = try_float env rhs body_c
+	-- First, bind large let-body if necessary
+	if ok_to_dup || isSingleton (nonErrorRHSs alts)
+	then
+	    simplCase env scrut alts (\env rhs -> simpl_bind env rhs) body_ty
+	else
+	    bindLargeRhs env [binder] body_ty body_c	`thenSmpl` \ (extra_binding, new_body) ->
+	    let
+		body_c' = \env -> simplExpr env new_body []
+		case_c  = \env rhs -> simplBind env (NonRec binder rhs) body_c' body_ty
+	    in
+	    simplCase env scrut alts case_c body_ty	`thenSmpl` \ case_expr ->
+	    returnSmpl (Let extra_binding case_expr)
 
-  | otherwise
-  = done_float env rhs body_c
+    -- None of the above; simplify rhs and tidy up
+    simpl_bind env rhs
+      = simplRhsExpr env binder rhs 	`thenSmpl` \ rhs' ->
+	completeNonRec env binder rhs'	`thenSmpl` \ (new_env, binds) ->
+        body_c new_env			`thenSmpl` \ body' ->
+        returnSmpl (mkCoLetsAny binds body')
 
-  where
-    will_be_demanded = willBeDemanded (getIdDemandInfo id)
-    rhs_ty 	     = idType id
 
+	-- All this stuff is computed at the start of the simpl_bind loop
     float_lets       	      = switchIsSet env SimplFloatLetsExposingWHNF
     float_primops    	      = switchIsSet env SimplOkToFloatPrimOps
     ok_to_dup	     	      = switchIsSet env SimplOkToDupCode
@@ -855,40 +778,65 @@ simplBind env (NonRec binder@(id,occ_info) rhs) body_c body_ty
     try_let_to_case           = switchIsSet env SimplLetToCase
     no_float		      = switchIsSet env SimplNoLetFromStrictLet
 
-    -------------------------------------------
-    done_float env rhs body_c
-	= simplRhsExpr env binder rhs 	`thenSmpl` \ rhs' ->
-	  completeLet env binder rhs' body_c body_ty
+    will_be_demanded = willBeDemanded (getIdDemandInfo id)
+    rhs_ty 	     = idType id
 
-    ---------------------------------------
-    try_float env (Let bind rhs) body_c
-      = tick LetFloatFromLet                    `thenSmpl_`
-	simplBind env (fix_up_demandedness will_be_demanded bind)
-		      (\env -> try_float env rhs body_c) body_ty
+    rhs_is_whnf = case mkFormSummary rhs of
+			VarForm -> True
+			ValueForm -> True
+			other -> False
 
-    try_float env (Case scrut alts) body_c
-      | will_be_demanded || (float_primops && is_cheap_prim_app scrut)
-      = tick CaseFloatFromLet				`thenSmpl_`
+    let_floating_ok  = (will_be_demanded && not no_float) ||
+		       always_float_let_from_let ||
+		       floatExposesHNF float_lets float_primops ok_to_dup rhs
+\end{code}
 
-	-- First, bind large let-body if necessary
-	if no_need_to_bind_large_body then
-	    simplCase env scrut alts (\env rhs -> try_float env rhs body_c) body_ty
-	else
-	    bindLargeRhs env [binder] body_ty body_c	`thenSmpl` \ (extra_binding, new_body) ->
-	    let
-		body_c' = \env -> simplExpr env new_body []
-	    in
-	    simplCase env scrut alts
-		      (\env rhs -> try_float env rhs body_c')
-		      body_ty				`thenSmpl` \ case_expr ->
+Let to case
+~~~~~~~~~~~
+It's important to try let-to-case before floating. Consider
 
-	    returnSmpl (Let extra_binding case_expr)
-      where
-	no_need_to_bind_large_body
-	  = ok_to_dup || isSingleton (nonErrorRHSs alts)
+	let a*::Int = case v of {p1->e1; p2->e2}
+	in b
+
+(The * means that a is sure to be demanded.)
+If we do case-floating first we get this:
+
+	let k = \a* -> b
+	in case v of
+		p1-> let a*=e1 in k a
+		p2-> let a*=e2 in k a
+
+Now watch what happens if we do let-to-case first:
+
+	case (case v of {p1->e1; p2->e2}) of
+	  Int a# -> let a*=I# a# in b
+===>
+	let k = \a# -> let a*=I# a# in b
+	in case v of
+		p1 -> case e1 of I# a# -> k a#
+		p1 -> case e1 of I# a# -> k a#
+
+The latter is clearly better.  (Remember the reboxing let-decl for a
+is likely to go away, because after all b is strict in a.)
+
+We do not do let to case for WHNFs, e.g.
+
+	  let x = a:b in ...
+	  =/=>
+	  case a:b of x in ...
+
+as this is less efficient.  but we don't mind doing let-to-case for
+"bottom", as that will allow us to remove more dead code, if anything:
+
+	  let x = error in ...
+	  ===>
+	  case error  of x -> ...
+	  ===>
+	  error
+
+Notice that let to case occurs only if x is used strictly in its body
+(obviously).
 
-    try_float env other_rhs body_c = done_float env other_rhs body_c
-\end{code}
 
 Letrec expressions
 ~~~~~~~~~~~~~~~~~~
@@ -974,42 +922,16 @@ How to do it?
 \begin{code}
 simplBind env (Rec pairs) body_c body_ty
   =	-- Do floating, if necessary
-    (if float_lets || always_float_let_from_let
-     then
-	mapSmpl float pairs	`thenSmpl` \ floated_pairs_s ->
-	returnSmpl (concat floated_pairs_s)
-     else
-	returnSmpl pairs
-    )					`thenSmpl` \ floated_pairs ->
     let
-	binders = map fst floated_pairs
-    in
-    cloneIds env binders		`thenSmpl` \ ids' ->
-    let
-	env_w_clones = extendIdEnvWithClones env binders ids'
-	triples	     = zipEqual "simplBind" ids' floated_pairs
-    in
-
-    simplRecursiveGroup env_w_clones triples	`thenSmpl` \ (binding, new_env) ->
-
-    body_c new_env				`thenSmpl` \ body' ->
-
-    returnSmpl (Let binding body')
+        floated_pairs | do_floating = float_pairs pairs
+		      | otherwise   = pairs
 
-  where
-    ------------ Floating stuff -------------------
-
-    float_lets		      = switchIsSet env SimplFloatLetsExposingWHNF
-    always_float_let_from_let = switchIsSet env SimplAlwaysFloatLetsFromLets
+	ticks	      | do_floating = length floated_pairs - length pairs
+		      | otherwise   = 0
 
-    float (binder,rhs)
-      = let
-	    pairs_s = float_pair (binder,rhs)
-	in
-	case pairs_s of
-	  [_] -> returnSmpl pairs_s
-	  more_than_one
-	    -> tickN LetFloatFromLet (length pairs_s - 1) `thenSmpl_`
+	binders       = map fst floated_pairs
+    in
+    tickN LetFloatFromLet ticks		`thenSmpl_` 
 		-- It's important to increment the tick counts if we
 		-- do any floating.  A situation where this turns out
 		-- to be important is this:
@@ -1024,7 +946,23 @@ simplBind env (Rec pairs) body_c body_ty
 		-- mention x, in which case the y binding can be pulled
 		-- out as an enclosing let(rec), which in turn gives
 		-- the strictness analyser more chance.
-		returnSmpl pairs_s
+
+    cloneIds env binders			`thenSmpl` \ ids' ->
+    let
+       env_w_clones = extendIdEnvWithClones env binders ids'
+    in
+    simplRecursiveGroup env ids' floated_pairs	`thenSmpl` \ (binding, new_env) ->
+
+    body_c new_env				`thenSmpl` \ body' ->
+
+    returnSmpl (Let binding body')
+
+  where
+    ------------ Floating stuff -------------------
+
+    float_lets		      = switchIsSet env SimplFloatLetsExposingWHNF
+    always_float_let_from_let = switchIsSet env SimplAlwaysFloatLetsFromLets
+    do_floating 	      = float_lets || always_float_let_from_let
 
     float_pairs pairs = concat (map float_pair pairs)
 
@@ -1048,63 +986,25 @@ simplBind env (Rec pairs) body_c body_ty
 					      (pairs', body') = do_float body
     do_float other			    = ([], other)
 
-simplRecursiveGroup env triples
-  =	-- Toss out all the dead pairs?  No, there shouldn't be any!
-	-- Dead code is discarded by the occurrence analyser
+simplRecursiveGroup env new_ids pairs 
+  = 	-- Add unfoldings to the new_ids corresponding to their RHS
     let
-	    -- Separate the live triples into "inline"able and
-	    -- "ordinary" We're paranoid about duplication!
-	(inline_triples, ordinary_triples)
-	  = partition is_inline_triple triples
-
-	is_inline_triple (_, ((_,occ_info),_))
-	  = inlineUnconditionally False {-not ok_to_dup-} occ_info
-
-	    -- Now add in the inline_pairs info (using "env_w_clones"),
-	    -- so that we will save away suitably-clone-laden envs
-	    -- inside the InlineIts...).
-
-	    -- NOTE ALSO that we tie a knot here, because the
-	    -- saved-away envs must also include these very inlinings
-	    -- (they aren't stored anywhere else, and a late one might
-	    -- be used in an early one).
-
-	env_w_inlinings = foldl add_inline env inline_triples
-
-	add_inline env (id', (binder,rhs))
-	  = extendIdEnvWithInlining env env_w_inlinings binder rhs
-
-	    -- Separate the remaining bindings into the ones which
-	    -- need to be dealt with first (the "early" ones)
-	    -- and the others (the "late" ones)
-	(early_triples, late_triples)
-	  = partition is_early_triple ordinary_triples
-
-	is_early_triple (_, (_, Con _ _)) = True
-	is_early_triple (i, _           ) = idWantsToBeINLINEd i
+       occs            = [occ | ((_,occ), _) <- pairs]
+       new_ids_w_pairs = zipEqual "simplRecGp" new_ids pairs
+       rhs_env         = foldl extendEnvForRecBinding 
+		               env new_ids_w_pairs
     in
-	-- Process the early bindings first
-    mapSmpl (do_one_binding env_w_inlinings) early_triples	`thenSmpl` \ early_triples' ->
 
-	-- Now further extend the environment to record our knowledge
-	-- about the form of the binders bound in the constructor bindings
-    let
-	env_w_early_info = foldr add_early_info env_w_inlinings early_triples'
-	add_early_info (binder, (id', rhs')) env = extendUnfoldEnvGivenRhs env binder id' rhs'
-    in
-	-- Now process the non-constructor bindings
-    mapSmpl (do_one_binding env_w_early_info) late_triples	`thenSmpl` \ late_triples' ->
+    mapSmpl (\(binder,rhs) -> simplRhsExpr rhs_env binder rhs) pairs	`thenSmpl` \ new_rhss ->
 
-	-- Phew! We're done
     let
-	binding = Rec (map snd early_triples' ++ map snd late_triples')
+       new_pairs	   = zipEqual "simplRecGp" new_ids new_rhss
+       occs_w_new_pairs = zipEqual "simplRecGp" occs new_pairs
+       new_env      	   = foldl (\env (occ_info,(new_id,new_rhs)) -> 
+			  	    extendEnvGivenBinding env occ_info new_id new_rhs)
+			 	   env occs_w_new_pairs
     in
-    returnSmpl (binding, env_w_early_info)
-  where
-
-    do_one_binding env (id', (binder,rhs))
-      = simplRhsExpr env binder rhs `thenSmpl` \ rhs' ->
-	returnSmpl (binder, (id', rhs'))
+    returnSmpl (Rec new_pairs, new_env)
 \end{code}
 
 
@@ -1147,74 +1047,57 @@ variable) when we find a let-expression:
 where it is always good to ditch the binding for y, and replace y by
 x.  That's just what completeLetBinding does.
 
-\begin{code}
-completeLet
-	:: SimplEnv
-	-> InBinder
-	-> OutExpr		-- The simplified RHS
-	-> (SimplEnv -> SmplM OutExpr)		-- Body handler
-	-> OutType		-- Type of body
-	-> SmplM OutExpr
 
-completeLet env binder new_rhs body_c body_ty
+\begin{code}
+	-- Sigh: rather disgusting case for coercions. We want to 
+	-- ensure that all let-bound Coerces have atomic bodies, so
+	-- they can freely be inlined.
+completeNonRec env binder@(_,occ_info) (Coerce coercion ty rhs)
+  = (case rhs of
+	Var v -> returnSmpl (env, [], rhs)
+	Lit l -> returnSmpl (env, [], rhs)
+	other -> newId (coreExprType rhs)			`thenSmpl` \ inner_id ->
+		 completeNonRec env 
+			(inner_id, dangerousArgOcc) rhs		`thenSmpl` \ (env1, extra_bind) ->
+		-- Dangerous occ because, like constructor args,
+		-- it can be duplicated easily
+		let
+		atomic_rhs = case lookupId env1 inner_id of
+			  	LitArg l -> Lit l
+				VarArg v -> Var v
+		in
+		returnSmpl (env1, extra_bind, atomic_rhs)
+     )				`thenSmpl` \ (env1, extra_bind, atomic_rhs) ->
+	-- Tiresome to do all this, but we must treat the lit/var cases specially
+	-- or we get a tick for atomic rhs when effectively it's a no-op.
+
+     cloneId env1 binder				  `thenSmpl` \ new_id ->
+     let 
+	new_rhs = Coerce coercion ty atomic_rhs
+	env2    = extendIdEnvWithClone env1 binder new_id
+	new_env = extendEnvGivenBinding env2 occ_info new_id new_rhs
+     in
+     returnSmpl (new_env, extra_bind ++ [NonRec new_id new_rhs])
+	
+completeNonRec env binder new_rhs
   -- See if RHS is an atom, or a reusable constructor
   | maybeToBool maybe_atomic_rhs
   = let
 	new_env = extendIdEnvWithAtom env binder rhs_atom
     in
     tick atom_tick_type			`thenSmpl_`
-    body_c new_env
+    returnSmpl (new_env, [])
   where
-    maybe_atomic_rhs :: Maybe (OutArg, TickType)
-    maybe_atomic_rhs = exprToAtom env new_rhs
-	-- If the RHS is atomic, we return Just (atom, tick type)
-	-- otherwise Nothing
+    maybe_atomic_rhs		    = exprToAtom env new_rhs
     Just (rhs_atom, atom_tick_type) = maybe_atomic_rhs
 
-completeLet env binder@(id,_) new_rhs body_c body_ty
-  -- Maybe the rhs is an application of error, and sure to be demanded
-  | will_be_demanded &&
-    maybeToBool maybe_error_app
-  = tick CaseOfError			`thenSmpl_`
-    returnSmpl retyped_error_app
-  where
-    will_be_demanded	   = willBeDemanded (getIdDemandInfo id)
-    maybe_error_app        = maybeErrorApp new_rhs (Just body_ty)
-    Just retyped_error_app = maybe_error_app
-
-{-
-completeLet env binder (Coerce coercion ty rhs) body_c body_ty
-   -- Rhs is a coercion
-   | maybeToBool maybe_atomic_coerce_rhs
-   = tick tick_type		`thenSmpl_`
-     complete_coerce env rhs_atom rhs
-   where
-     maybe_atomic_coerce_rhs    = exprToAtom env rhs
-     Just (rhs_atom, tick_type) = maybe_atomic_coerce_rhs
-
-	  returnSmpl (CoerceForm coercion rhs_atom, env)
-	Nothing
-	  newId (coreExprType rhs)	`thenSmpl` \ inner_id ->
-	  
-     complete_coerce env atom rhs
-       = cloneId env binder			`thenSmpl` \ id' ->
-	 let
-	    env1    = extendIdEnvWithClone env binder id'
-	    new_env = extendUnfoldEnvGivenFormDetails env1 id' (CoerceForm coercion rhs_atom)
-	 in
-	 body_c new_env			`thenSmpl` \ body' ->
-	 returnSmpl (Let (NonRec id' (Coerce coercion ty rhs) body')
--}   
-
-completeLet env binder new_rhs body_c body_ty
-  -- The general case
-  = cloneId env binder			`thenSmpl` \ id' ->
+completeNonRec env binder@(_,occ_info) new_rhs
+  = cloneId env binder			`thenSmpl` \ new_id ->
     let
-	env1    = extendIdEnvWithClone env binder id'
-	new_env = extendUnfoldEnvGivenRhs env1 binder id' new_rhs
+	env1    = extendIdEnvWithClone env binder new_id
+	new_env = extendEnvGivenBinding env1 occ_info new_id new_rhs
     in
-    body_c new_env			`thenSmpl` \ body' ->
-    returnSmpl (Let (NonRec id' new_rhs) body')
+    returnSmpl (new_env, [NonRec new_id new_rhs])
 \end{code}
 
 %************************************************************************
@@ -1228,17 +1111,7 @@ simplArg :: SimplEnv -> InArg -> OutArg
 
 simplArg env (LitArg lit) = LitArg lit
 simplArg env (TyArg  ty)  = TyArg  (simplTy env ty)
-
-simplArg env (VarArg id)
-  | isLocallyDefined id
-  = case lookupId env id of
-	Just (ItsAnAtom atom) -> atom
-	Just (InlineIt _ _ _) -> pprPanic "simplArg InLineIt:" (ppAbove (ppr PprDebug id) (pprSimplEnv env))
-	Nothing		      -> VarArg id 	-- Must be an uncloned thing
-
-  | otherwise
-  = 	-- Not locally defined, so no change
-    VarArg id
+simplArg env (VarArg id)  = lookupId env id
 \end{code}
 
 
diff --git a/ghc/compiler/specialise/SpecEnv.lhs b/ghc/compiler/specialise/SpecEnv.lhs
index 2d94809c97..d7528b8c7f 100644
--- a/ghc/compiler/specialise/SpecEnv.lhs
+++ b/ghc/compiler/specialise/SpecEnv.lhs
@@ -9,8 +9,7 @@
 module SpecEnv (
 	SYN_IE(SpecEnv), MatchEnv,
 	nullSpecEnv, isNullSpecEnv,
-	addOneToSpecEnv, lookupSpecEnv,
-	specEnvToList
+	addOneToSpecEnv, lookupSpecEnv
     ) where
 
 IMP_Ubiq()
@@ -18,14 +17,20 @@ IMP_Ubiq()
 import MatchEnv
 import Type		( matchTys, isTyVarTy )
 import Usage		( SYN_IE(UVar) )
+import OccurAnal	( occurAnalyseGlobalExpr )
+import CoreSyn		( CoreExpr(..), SimplifiableCoreExpr(..) )
+import Maybes		( MaybeErr(..) )
 \end{code}
 
 
-A @SpecEnv@ holds details of an @Id@'s specialisations:
+A @SpecEnv@ holds details of an @Id@'s specialisations.  It should be
+a newtype (ToDo), but for 1.2 compatibility we make it a data type.
+It can't be a synonym because there's an IdInfo instance of it
+that doesn't work if it's (MatchEnv a b).
+Furthermore, making it a data type makes it easier to break the IdInfo loop.
 
 \begin{code}
-type CoreExpr = GenCoreExpr Id Id TyVar Unique
-type SpecEnv = MatchEnv [Type] CoreExpr
+data SpecEnv = SpecEnv (MatchEnv [Type] SimplifiableCoreExpr)
 \end{code}
 
 For example, if \tr{f}'s @SpecEnv@ contains the mapping:
@@ -55,216 +60,19 @@ where pi' :: Lift Int# is the specialised version of pi.
 
 \begin{code}
 nullSpecEnv :: SpecEnv
-nullSpecEnv = nullMEnv
+nullSpecEnv = SpecEnv nullMEnv
 
 isNullSpecEnv :: SpecEnv -> Bool
-isNullSpecEnv env = null (mEnvToList env)
+isNullSpecEnv (SpecEnv env) = null (mEnvToList env)
 
-specEnvToList :: SpecEnv -> [([Type],CoreExpr)]
-specEnvToList env = mEnvToList env
-	
-addOneToSpecEnv :: SpecEnv -> [Type] -> CoreExpr -> MaybeErr SpecEnv ([Type], CoreExpr)
-addOneToSpecEnv env tys rhs = insertMEnv matchTys env tys rhs
+addOneToSpecEnv :: SpecEnv -> [Type] -> CoreExpr -> MaybeErr SpecEnv ([Type], SimplifiableCoreExpr)
+addOneToSpecEnv (SpecEnv env) tys rhs 
+  = case (insertMEnv matchTys env tys (occurAnalyseGlobalExpr rhs)) of
+	Succeeded menv -> Succeeded (SpecEnv menv)
+	Failed err     -> Failed err
 
-lookupSpecEnv :: SpecEnv -> [Type] -> Maybe (CoreExpr, [(TyVar,Type)])
-lookupSpecEnv env tys 
+lookupSpecEnv :: SpecEnv -> [Type] -> Maybe (SimplifiableCoreExpr, ([(TyVar,Type)], [Type]))
+lookupSpecEnv (SpecEnv env) tys 
   | all isTyVarTy tys = Nothing	-- Short cut: no specialisation for simple tyvars
   | otherwise	      = lookupMEnv matchTys env tys
 \end{code}
-
-
-
-=================================================================
-	BELOW HERE SCHEDULED FOR DELETION!
-
-
-The details of one specialisation, held in an @Id@'s
-@SpecEnv@ are as follows:
-\begin{pseudocode}
-data SpecInfo
-  = SpecInfo	[Maybe Type] -- Instance types; no free type variables in here
-	    	Int		-- No. of dictionaries to eat
-		Id		-- Specialised version
-\end{pseudocode}
-
-For example, if \tr{f} has this @SpecInfo@:
-\begin{verbatim}
-	SpecInfo [Just t1, Nothing, Just t3] 2 f'
-\end{verbatim}
-then
-\begin{verbatim}
-	f t1 t2 t3 d1 d2  ===>  f t2
-\end{verbatim}
-The \tr{Nothings} identify type arguments in which the specialised
-version is polymorphic.
-
-\begin{pseudocode}
-data SpecEnv = SpecEnv [SpecInfo]
-
-mkSpecEnv = SpecEnv
-nullSpecEnv = SpecEnv []
-addOneToSpecEnv (SpecEnv xs) x = SpecEnv (x : xs)
-
-
-lookupConstMethodId :: Id -> Type -> Maybe Id
-    -- slight variant on "lookupSpecEnv" below
-
-lookupConstMethodId sel_id spec_ty
-  = case (getInfo (getIdInfo sel_id)) of
-      SpecEnv spec_infos -> firstJust (map try spec_infos)
-  where
-    try (SpecInfo (Just ty:nothings) _ const_meth_id)
-      = ASSERT(all nothing_is_nothing nothings)
-	case (cmpType True{-properly-} ty spec_ty) of
-	  EQ_ -> Just const_meth_id
-	  _   -> Nothing
-
-    nothing_is_nothing Nothing = True  -- debugging only
-    nothing_is_nothing _ = panic "nothing_is_nothing!"
-
-lookupSpecId :: Id		-- *un*specialised Id
-	     -> [Maybe Type]	-- types to which it is to be specialised
-	     -> Id		-- specialised Id
-
-lookupSpecId unspec_id ty_maybes
-  = case (getInfo (getIdInfo unspec_id))  of { SpecEnv spec_infos ->
-
-    case (firstJust (map try spec_infos)) of
-      Just id -> id
-      Nothing -> pprError "ERROR: There is some confusion about a value specialised to a type;\ndetails follow (and more info in the User's Guide):\n\t"
-			  (ppr PprDebug unspec_id)
-    }
-  where
-    try (SpecInfo template_maybes _ id)
-	| and (zipWith same template_maybes ty_maybes)
-	&& length template_maybes == length ty_maybes = Just id
-	| otherwise 				      = Nothing
-
-    same Nothing    Nothing    = True
-    same (Just ty1) (Just ty2) = ty1 == ty2
-    same _	    _	       = False
-
-lookupSpecEnv :: SpecEnv
-	      -> [Type]
-	      -> Maybe (Id,
-			[Type],
-			Int)
-
-lookupSpecEnv (SpecEnv []) _ = Nothing 	-- rather common case
-
-lookupSpecEnv spec_env [] = Nothing	-- another common case
-
-	-- This can happen even if there is a non-empty spec_env, because
-	-- of eta reduction.  For example, we might have a defn
-	--
-	--	f = /\a -> \d -> g a d
-	-- which gets transformed to
-	--	f = g
-	--
-	-- Now g isn't applied to any arguments
-
-lookupSpecEnv se@(SpecEnv spec_infos) spec_tys
-  = select_match spec_infos
-  where
-    select_match []		-- no matching spec_infos
-      = Nothing
-    select_match (SpecInfo ty_maybes toss spec_id : rest)
-      = case (match ty_maybes spec_tys) of
-	  Nothing       -> select_match rest
-	  Just tys_left -> select_next [(spec_id,tys_left,toss)] (length tys_left) toss rest
-
-	-- Ambiguity can only arise as a result of specialisations with
-	-- an explicit spec_id. The best match is deemed to be the match
-	-- with least polymorphism i.e. has the least number of tys left.
-	-- This is a non-critical approximation. The only type arguments
-	-- where there may be some discretion is for non-overloaded boxed
-	-- types. Unboxed types must be matched and we insist that we
-	-- always specialise on overloaded types (and discard all the dicts).
-
-    select_next best _ toss []
-      =	case best of
-	    [match] -> Just match	-- Unique best match
-	    ambig   -> pprPanic "Ambiguous Specialisation:\n"
-				(ppAboves [ppStr "(check specialisations with explicit spec ids)",
-					   ppCat (ppStr "between spec ids:" :
-						  map (ppr PprDebug) [id | (id, _, _) <- ambig]),
-					   pp_stuff])
-
-    select_next best tnum dnum (SpecInfo ty_maybes toss spec_id : rest)
-      = ASSERT(dnum == toss)
-	case (match ty_maybes spec_tys) of
-	  Nothing       -> select_next best tnum dnum rest
-	  Just tys_left ->
-	     let tys_len = length tys_left in
-	     case _tagCmp tnum tys_len of
-	       _LT -> select_next [(spec_id,tys_left,toss)] tys_len dnum rest	-- better match
-	       _EQ -> select_next ((spec_id,tys_left,toss):best) tnum dnum rest	-- equivalent match
-	       _GT -> select_next best tnum dnum rest				-- worse match
-
-
-    match [{-out of templates-}] [] = Just []
-
-    match (Nothing:ty_maybes) (spec_ty:spec_tys)
-      = case (isUnboxedType spec_ty) of
-	  True  -> Nothing	-- Can only match boxed type against
-				-- type argument which has not been
-				-- specialised on
-	  False -> case match ty_maybes spec_tys of
-		     Nothing  -> Nothing
-		     Just tys -> Just (spec_ty:tys)
-
-    match (Just ty:ty_maybes) (spec_ty:spec_tys)
-      = case (cmpType True{-properly-} ty spec_ty) of
-	  EQ_   -> match ty_maybes spec_tys
-	  other -> Nothing
-
-    match [] _ = pprPanic "lookupSpecEnv1\n" pp_stuff
-		 -- This is a Real Problem
-
-    match _ [] = pprPanic "lookupSpecEnv2\n" pp_stuff
-		 -- Partial eta abstraction might make this happen;
-		 -- meanwhile let's leave in the check
-
-    pp_stuff = ppAbove (pp_specs PprDebug True (\x->x) nullIdEnv se) (ppr PprDebug spec_tys)
-\end{pseudocode}
-
-
-\begin{pseudocode}
-instance OptIdInfo SpecEnv where
-    noInfo = nullSpecEnv
-
-    getInfo (IdInfo _ _ spec _ _ _ _ _ _ _) = spec
-
-    addInfo (IdInfo a b (SpecEnv old_spec) d e f g h i j) (SpecEnv new_spec)
-	= IdInfo a b (SpecEnv (new_spec ++ old_spec)) d e f g h i j
-	-- We *add* the new specialisation info rather than just replacing it
-	-- so that we don't lose old specialisation details.
-
-    ppInfo sty better_id_fn spec_env
-      = pp_specs sty True better_id_fn nullIdEnv spec_env
-
-pp_specs sty _ _ _ (SpecEnv [])  = pp_NONE
-pp_specs sty print_spec_ids better_id_fn inline_env (SpecEnv specs)
-  = ppBeside (ppPStr SLIT("_SPECIALISE_ ")) (pp_the_list [
-       ppCat [ppLbrack, ppIntersperse pp'SP{-'-} (map pp_maybe ty_maybes), ppRbrack,
-	      ppInt numds,
-	      let
-		 better_spec_id = better_id_fn spec_id
-		 spec_id_info = getIdInfo better_spec_id
-	      in
-	      if not print_spec_ids || boringIdInfo spec_id_info then
-		 ppNil
-	      else
-		 ppCat [ppChar '{',
-			ppIdInfo sty better_spec_id True{-wrkr specs too!-} better_id_fn inline_env spec_id_info,
-			ppChar '}']
-	     ]
-       | (SpecInfo ty_maybes numds spec_id) <- specs ])
-  where
-    pp_the_list [p]    = p
-    pp_the_list (p:ps) = ppBesides [p, pp'SP{-'-}, pp_the_list ps]
-
-    pp_maybe Nothing  = ifPprInterface sty pp_NONE
-    pp_maybe (Just t) = pprParendGenType sty t
-\end{pseudocode}
-
diff --git a/ghc/compiler/specialise/Specialise.lhs b/ghc/compiler/specialise/Specialise.lhs
index 266d177581..424bcad5e4 100644
--- a/ghc/compiler/specialise/Specialise.lhs
+++ b/ghc/compiler/specialise/Specialise.lhs
@@ -77,7 +77,7 @@ infixr 9 `thenSM`
 
 --ToDo:kill
 data SpecInfo = SpecInfo [Maybe Type] Int Id
-
+lookupSpecEnv = panic "Specialise.lookupSpecEnv (ToDo)"
 addIdSpecialisation = panic "Specialise.addIdSpecialisation (ToDo)"
 cmpUniTypeMaybeList = panic "Specialise.cmpUniTypeMaybeList (ToDo)"
 getIdSpecialisation = panic "Specialise.getIdSpecialisation (ToDo)"
@@ -88,7 +88,6 @@ isLocalSpecTyCon = panic "Specialise.isLocalSpecTyCon (ToDo)"
 isSpecId_maybe = panic "Specialise.isSpecId_maybe (ToDo)"
 isSpecPragmaId_maybe = panic "Specialise.isSpecPragmaId_maybe (ToDo)"
 lookupClassInstAtSimpleType = panic "Specialise.lookupClassInstAtSimpleType (ToDo)"
-lookupSpecEnv = panic "Specialise.lookupSpecEnv (ToDo)"
 mkSpecEnv = panic "Specialise.mkSpecEnv (ToDo)"
 mkSpecId = panic "Specialise.mkSpecId (ToDo)"
 selectIdInfoForSpecId = panic "Specialise.selectIdInfoForSpecId (ToDo)"
@@ -930,11 +929,11 @@ emptyUDs    :: UsageDetails
 unionUDs    :: UsageDetails -> UsageDetails -> UsageDetails
 unionUDList :: [UsageDetails] -> UsageDetails
 
-tickSpecCall :: Bool -> UsageDetails -> UsageDetails
+-- tickSpecCall :: Bool -> UsageDetails -> UsageDetails
 tickSpecInsts :: UsageDetails -> UsageDetails
 
-tickSpecCall found (UsageDetails cis ty_cis dbs fvs c i)
- = UsageDetails cis ty_cis dbs fvs (c + (if found then 1 else 0)) i
+-- tickSpecCall found (UsageDetails cis ty_cis dbs fvs c i)
+-- = UsageDetails cis ty_cis dbs fvs (c + (if found then 1 else 0)) i
 
 tickSpecInsts (UsageDetails cis ty_cis dbs fvs c i)
  = UsageDetails cis ty_cis dbs fvs c (i+1)
@@ -1298,14 +1297,14 @@ specExpr (Var v) args
        NoLift vatom@(VarArg new_v)
 	     -> mapSM specOutArg args			`thenSM` \ arg_info ->
 		mkCallInstance v new_v arg_info		`thenSM` \ call_uds ->
-    		mkCall new_v arg_info			`thenSM` \ ~(speced, call) ->
+    		mkCall new_v arg_info			`thenSM` \ call ->
 		let
 		    uds = unionUDList [call_uds,
 				       singleFvUDs vatom,
 				       unionUDList [uds | (_,uds,_) <- arg_info]
 				      ]
 		in
-    		returnSM (call, tickSpecCall speced uds)
+    		returnSM (call, {- tickSpecCall speced -} uds)
 
 specExpr expr@(Lit _) null_args
   = ASSERT (null null_args)
@@ -1975,7 +1974,7 @@ mkOneInst do_cis@(CallInstance _ spec_tys dict_args _ _) explicit_cis
 		-- "required" by one of the other Ids in the Rec
 	  | top_lev && maybeToBool lookup_orig_spec
 	  = (if opt_SpecialiseTrace
-	     then trace_nospec "  Exists: " exists_id
+	     then trace_nospec "  Exists: " orig_id
 	     else id) (
 
 	    returnSM (Nothing, emptyUDs, Nothing)
@@ -2023,7 +2022,6 @@ mkOneInst do_cis@(CallInstance _ spec_tys dict_args _ _) explicit_cis
 			  tickSpecInsts final_uds, spec_info)
 	  where
 	    lookup_orig_spec = lookupSpecEnv (getIdSpecialisation orig_id) arg_tys
-	    Just (exists_id, _, _) = lookup_orig_spec
 
 	    explicit_cis_for_this_id = filter (isCIofTheseIds [new_id]) explicit_cis
 	    [CallInstance _ _ _ _ (Just explicit_spec_info)] = explicit_cis_for_this_id
@@ -2199,9 +2197,11 @@ take_dict_args [] args = Just ([], args)
 \begin{code}
 mkCall :: Id
        -> [(CoreArg, UsageDetails, CoreExpr -> CoreExpr)]
-       -> SpecM (Bool, CoreExpr)
+       -> SpecM CoreExpr
 
-mkCall new_id args
+mkCall new_id arg_infos = returnSM (mkGenApp (Var new_id) [arg | (arg, _, _) <- arg_infos])
+
+{- 
   | maybeToBool (isSuperDictSelId_maybe new_id)
     && any isUnboxedType ty_args
 	-- No specialisations for super-dict selectors
@@ -2308,6 +2308,7 @@ checkSpecOK check_id tys spec_id tys_left
 			     ppCat [ppr PprDebug spec_id,
 				    ppInterleave ppNil (map (pprParendGenType PprDebug) tys_left)]])
     else id
+-}
 \end{code}
 
 \begin{code}
diff --git a/ghc/compiler/stranal/SaAbsInt.lhs b/ghc/compiler/stranal/SaAbsInt.lhs
index 11adf777a5..cb9509a06a 100644
--- a/ghc/compiler/stranal/SaAbsInt.lhs
+++ b/ghc/compiler/stranal/SaAbsInt.lhs
@@ -18,7 +18,7 @@ module SaAbsInt (
 IMP_Ubiq(){-uitous-}
 
 import CoreSyn
-import CoreUnfold	( UnfoldingDetails(..), FormSummary )
+import CoreUnfold	( Unfolding(..), SimpleUnfolding(..), FormSummary )
 import CoreUtils	( unTagBinders )
 import Id		( idType, getIdStrictness, getIdUnfolding,
 			  dataConTyCon, dataConArgTys
@@ -393,7 +393,7 @@ absId anal var env
 	(Just abs_val, _, _) ->
 			abs_val	-- Bound in the environment
 
-	(Nothing, NoStrictnessInfo, GenForm _ unfolding _) ->
+	(Nothing, NoStrictnessInfo, CoreUnfolding (SimpleUnfolding _ _ unfolding)) ->
 			-- We have an unfolding for the expr
 			-- Assume the unfolding has no free variables since it
 			-- came from inside the Id
@@ -419,7 +419,7 @@ absId anal var env
 
 
 	(Nothing, strictness_info, _) ->
-			-- Includes MagicForm, IWantToBeINLINEd, NoUnfoldingDetails
+			-- Includes MagicUnfolding, NoUnfolding
 			-- Try the strictness info
 			absValFromStrictness anal strictness_info
     in
diff --git a/ghc/compiler/stranal/StrictAnal.lhs b/ghc/compiler/stranal/StrictAnal.lhs
index 34685fb43c..b0c21b4525 100644
--- a/ghc/compiler/stranal/StrictAnal.lhs
+++ b/ghc/compiler/stranal/StrictAnal.lhs
@@ -403,21 +403,25 @@ addStrictnessInfoToId
 	-> Id			-- Augmented with strictness
 
 addStrictnessInfoToId strflags str_val abs_val binder body
-  = if isWrapperId binder then
-	binder	-- Avoid clobbering existing strictness info
+
+{-		SCHEDULED FOR NUKING 
+  | isWrapperId binder
+  = binder	-- Avoid clobbering existing strictness info
 		-- (and, more importantly, worker info).
 		-- Deeply suspicious (SLPJ)
-    else
-    if (isBot str_val) then
-	binder `addIdStrictness` mkBottomStrictnessInfo
-    else
-	case (collectBinders body) of { (_, _, lambda_bounds, rhs) ->
-	let
-		tys        = map idType lambda_bounds
-		strictness = findStrictness strflags tys str_val abs_val
-	in
-	binder `addIdStrictness` mkStrictnessInfo strictness Nothing
-	}
+-}
+
+  | isBot str_val
+  = binder `addIdStrictness` mkBottomStrictnessInfo
+
+  | otherwise
+  = case (collectBinders body) of { (_, _, lambda_bounds, rhs) ->
+    let
+	tys        = map idType lambda_bounds
+	strictness = findStrictness strflags tys str_val abs_val
+    in
+    binder `addIdStrictness` mkStrictnessInfo strictness Nothing
+    }
 \end{code}
 
 \begin{code}
diff --git a/ghc/compiler/stranal/WorkWrap.lhs b/ghc/compiler/stranal/WorkWrap.lhs
index 3df667f37a..8a8ff80c51 100644
--- a/ghc/compiler/stranal/WorkWrap.lhs
+++ b/ghc/compiler/stranal/WorkWrap.lhs
@@ -11,7 +11,7 @@ module WorkWrap ( workersAndWrappers ) where
 IMP_Ubiq(){-uitous-}
 
 import CoreSyn
-import CoreUnfold	( UnfoldingDetails(..){-ToDo:rm-}, UnfoldingGuidance(..) )
+import CoreUnfold	( Unfolding(..), UnfoldingGuidance(..) )
 IMPORT_DELOOPER(IdLoop)	 -- ToDo:rm when iWantToBeINLINEd goes
 
 import CoreUtils	( coreExprType )
@@ -25,8 +25,8 @@ import SaLib
 import UniqSupply	( returnUs, thenUs, mapUs, getUnique, SYN_IE(UniqSM) )
 import WwLib
 
-iWantToBeINLINEd :: UnfoldingGuidance -> UnfoldingDetails
-iWantToBeINLINEd x = NoUnfoldingDetails --ToDo:panic "WorkWrap.iWantToBeINLINEd (ToDo)"
+iWantToBeINLINEd :: UnfoldingGuidance -> Unfolding
+iWantToBeINLINEd x = NoUnfolding --ToDo:panic "WorkWrap.iWantToBeINLINEd (ToDo)"
 \end{code}
 
 We take Core bindings whose binders have their strictness attached (by
diff --git a/ghc/compiler/typecheck/GenSpecEtc.lhs b/ghc/compiler/typecheck/GenSpecEtc.lhs
index f3cf96af00..e3d6267121 100644
--- a/ghc/compiler/typecheck/GenSpecEtc.lhs
+++ b/ghc/compiler/typecheck/GenSpecEtc.lhs
@@ -18,6 +18,7 @@ import TcMonad		hiding ( rnMtoTcM )
 import Inst		( Inst, InstOrigin(..), SYN_IE(LIE), plusLIE, 
 			  newDicts, tyVarsOfInst, instToId )
 import TcEnv		( tcGetGlobalTyVars, tcExtendGlobalTyVars )
+import SpecEnv		( SpecEnv )
 import TcSimplify	( tcSimplify, tcSimplifyAndCheck )
 import TcType		( SYN_IE(TcType), SYN_IE(TcThetaType), SYN_IE(TcTauType), 
 			  SYN_IE(TcTyVarSet), SYN_IE(TcTyVar),
@@ -166,7 +167,7 @@ genBinds binder_names mono_ids bind lie sig_infos prag_info_fn
 	unresolved_kind_tyvars = filter (isTypeKind    . tyVarKind) tyvars
 
 	box_it tyvar = newTyVarTy mkBoxedTypeKind	`thenNF_Tc` \ boxed_ty ->
-		       unifyTauTy (mkTyVarTy tyvar) boxed_ty
+		       unifyTauTy boxed_ty (mkTyVarTy tyvar) 
 
     in
     ASSERT( null unboxed_kind_tyvars )	-- The instCantBeGeneralised stuff in tcSimplify
diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs
index 4424e98310..34f09908a8 100644
--- a/ghc/compiler/typecheck/Inst.lhs
+++ b/ghc/compiler/typecheck/Inst.lhs
@@ -54,7 +54,7 @@ import Id	( GenId, idType, mkInstId )
 import MatchEnv	( lookupMEnv, insertMEnv )
 import Name	( mkLocalName, getLocalName, Name )
 import Outputable
-import PprType	( GenClass, TyCon, GenType, GenTyVar )	
+import PprType	( GenClass, TyCon, GenType, GenTyVar, pprParendGenType )	
 import PprStyle	( PprStyle(..) )
 import Pretty
 import SpecEnv	( SYN_IE(SpecEnv) )
@@ -364,7 +364,7 @@ ppr_inst sty hdr ppr_orig (LitInst u lit ty orig loc)
 
 ppr_inst sty hdr ppr_orig (Dict u clas ty orig loc)
   = ppHang (ppr_orig orig loc)
-	 4 (ppCat [ppr sty clas, ppr sty ty, show_uniq sty u])
+	 4 (ppCat [ppr sty clas, pprParendGenType sty ty, show_uniq sty u])
 
 ppr_inst sty hdr ppr_orig (Method u id tys rho orig loc)
   = ppHang (ppr_orig orig loc)
diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs
index a733638c9e..7d5b01c006 100644
--- a/ghc/compiler/typecheck/TcBinds.lhs
+++ b/ghc/compiler/typecheck/TcBinds.lhs
@@ -24,6 +24,7 @@ import TcMonad		hiding ( rnMtoTcM )
 import GenSpecEtc	( checkSigTyVars, genBinds, TcSigInfo(..) )
 import Inst		( Inst, SYN_IE(LIE), emptyLIE, plusLIE, InstOrigin(..) )
 import TcEnv		( tcExtendLocalValEnv, tcLookupLocalValueOK, newMonoIds )
+import SpecEnv		( SpecEnv )
 IMPORT_DELOOPER(TcLoop)		( tcGRHSsAndBinds )
 import TcMatches	( tcMatchesFun )
 import TcMonoType	( tcPolyType )
diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs
index 8e1c047aa0..c2818b3453 100644
--- a/ghc/compiler/typecheck/TcClassDcl.lhs
+++ b/ghc/compiler/typecheck/TcClassDcl.lhs
@@ -25,6 +25,7 @@ import TcHsSyn		( TcIdOcc(..), SYN_IE(TcHsBinds), SYN_IE(TcMonoBinds), SYN_IE(Tc
 
 import Inst		( Inst, InstOrigin(..), SYN_IE(LIE), emptyLIE, plusLIE, newDicts, newMethod )
 import TcEnv		( tcLookupClass, tcLookupTyVar, tcLookupTyCon, newLocalIds, tcExtendGlobalTyVars )
+import SpecEnv		( SpecEnv )
 import TcInstDcls	( processInstBinds )
 import TcKind		( unifyKind, TcKind )
 import TcMonad		hiding ( rnMtoTcM )
@@ -39,7 +40,7 @@ import Class		( GenClass, mkClass, mkClassOp, classBigSig,
 			)
 import Id		( mkSuperDictSelId, mkMethodSelId, mkDefaultMethodId,
 			  idType )
-import IdInfo		( noIdInfo )
+import IdInfo
 import Name		( isLocallyDefined, origName, getLocalName )
 import PrelVals		( nO_DEFAULT_METHOD_ERROR_ID )
 import PprStyle
@@ -57,7 +58,8 @@ import Util
 
 -- import TcPragmas	( tcGenPragmas, tcClassOpPragmas )
 tcGenPragmas ty id ps = returnNF_Tc noIdInfo
-tcClassOpPragmas ty sel def spec ps = returnNF_Tc (noIdInfo, noIdInfo)
+tcClassOpPragmas ty sel def spec ps = returnNF_Tc (noIdInfo `addInfo` spec, 
+						   noIdInfo)
 \end{code}
 
 
diff --git a/ghc/compiler/typecheck/TcDefaults.lhs b/ghc/compiler/typecheck/TcDefaults.lhs
index 3d40162240..066f90e625 100644
--- a/ghc/compiler/typecheck/TcDefaults.lhs
+++ b/ghc/compiler/typecheck/TcDefaults.lhs
@@ -18,6 +18,7 @@ import TcHsSyn		( TcIdOcc )
 import TcMonad		hiding ( rnMtoTcM )
 import Inst		( InstOrigin(..) )
 import TcEnv		( tcLookupClassByKey )
+import SpecEnv		( SpecEnv )
 import TcMonoType	( tcMonoType )
 import TcSimplify	( tcSimplifyCheckThetas )
 
diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs
index 572fcb99aa..35995fd0b7 100644
--- a/ghc/compiler/typecheck/TcDeriv.lhs
+++ b/ghc/compiler/typecheck/TcDeriv.lhs
@@ -22,6 +22,7 @@ import TcHsSyn		( TcIdOcc )
 import TcMonad
 import Inst		( SYN_IE(InstanceMapper) )
 import TcEnv		( getEnv_TyCons, tcLookupClassByKey )
+import SpecEnv		( SpecEnv )
 import TcKind		( TcKind )
 import TcGenDeriv	-- Deriv stuff
 import TcInstUtil	( InstInfo(..), mkInstanceRelatedIds, buildInstanceEnvs )
diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs
index 77308e5f25..8015b6ded1 100644
--- a/ghc/compiler/typecheck/TcExpr.lhs
+++ b/ghc/compiler/typecheck/TcExpr.lhs
@@ -33,6 +33,7 @@ import TcEnv		( tcLookupLocalValue, tcLookupGlobalValue, tcLookupClassByKey,
 			  tcLookupGlobalValueByKey, newMonoIds, tcGetGlobalTyVars,
 			  tcExtendGlobalTyVars
 			)
+import SpecEnv		( SpecEnv )
 import TcMatches	( tcMatchesCase, tcMatch )
 import TcMonoType	( tcPolyType )
 import TcPat		( tcPat )
@@ -229,7 +230,7 @@ tcExpr in_expr@(SectionR op expr)
     newTyVarTy mkTypeKind	`thenNF_Tc` \ ty1 ->
     newTyVarTy mkTypeKind	`thenNF_Tc` \ ty2 ->
     tcAddErrCtxt (sectionRAppCtxt in_expr) $
-    unifyTauTy op_ty (mkFunTys [ty1, expr_ty] ty2)     `thenTc_`
+    unifyTauTy (mkFunTys [ty1, expr_ty] ty2) op_ty      `thenTc_`
 
     returnTc (SectionR op' expr', lie1 `plusLIE` lie2, mkFunTy ty1 ty2)
 \end{code}
@@ -303,7 +304,7 @@ tcExpr (HsIf pred b1 b2 src_loc)
     tcExpr pred			`thenTc`    \ (pred',lie1,predTy) ->
 
     tcAddErrCtxt (predCtxt pred) (
-      unifyTauTy predTy boolTy
+      unifyTauTy boolTy predTy
     )				`thenTc_`
 
     tcExpr b1			`thenTc`    \ (b1',lie2,result_ty) ->
@@ -469,7 +470,7 @@ tcExpr in_expr@(ExprWithTySig expr poly_ty)
    let
 	(sig_tyvars', sig_theta', sig_tau') = splitSigmaTy sigma_sig'
    in
-   unifyTauTy tau_ty sig_tau'		`thenTc_`
+   unifyTauTy sig_tau' tau_ty		`thenTc_`
 
 	-- Check the type variables of the signature
    checkSigTyVars sig_tyvars' sig_tau'	`thenTc_`
@@ -783,7 +784,7 @@ tcDoStmts stmts src_loc
 		-- See comments with tcListComp on GeneratorQual
 
 		get_m_arg exp_ty	`thenTc` \ a ->
-		unifyTauTy a pat_ty	`thenTc_`
+		unifyTauTy pat_ty a	`thenTc_`
 		returnTc (a, pat', exp', pat_lie `plusLIE` exp_lie)
 	  ))				`thenTc` \ (a, pat', exp', stmt_lie) ->
 	  go stmts			`thenTc` \ (stmts', stmts_lie, stmts_ty) ->
diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs
index 6f7e3a372c..e12fb7ae82 100644
--- a/ghc/compiler/typecheck/TcInstDcls.lhs
+++ b/ghc/compiler/typecheck/TcInstDcls.lhs
@@ -39,6 +39,7 @@ import Inst		( Inst, InstOrigin(..), SYN_IE(InstanceMapper),
 import TcBinds		( tcPragmaSigs )
 import TcDeriv		( tcDeriving )
 import TcEnv		( tcLookupClass, tcTyVarScope, newLocalId, tcExtendGlobalTyVars )
+import SpecEnv		( SpecEnv )
 import TcGRHSs		( tcGRHSsAndBinds )
 import TcInstUtil	( InstInfo(..), mkInstanceRelatedIds, buildInstanceEnvs )
 import TcKind		( TcKind, unifyKind )
@@ -631,7 +632,7 @@ processInstBinds1 clas avail_insts method_ids mbind
 		-- Make the method_tyvars into signature tyvars so they
 		-- won't get unified with anything.
 	tcInstSigTyVars method_tyvars		`thenNF_Tc` \ (sig_tyvars, sig_tyvar_tys, _) ->
-	unifyTauTyLists (mkTyVarTys method_tyvars) sig_tyvar_tys	`thenTc_`
+	unifyTauTyLists sig_tyvar_tys (mkTyVarTys method_tyvars)	`thenTc_`
 
 	newLocalId occ method_tau		`thenNF_Tc` \ local_id ->
 	newLocalId occ method_ty		`thenNF_Tc` \ copy_id ->
diff --git a/ghc/compiler/typecheck/TcMatches.lhs b/ghc/compiler/typecheck/TcMatches.lhs
index 313dc5a633..1eba8210bd 100644
--- a/ghc/compiler/typecheck/TcMatches.lhs
+++ b/ghc/compiler/typecheck/TcMatches.lhs
@@ -132,7 +132,7 @@ tcMatchExpected expected_ty the_match@(PatMatch pat match)
 	Nothing ->			-- Not a function type (eg type variable)
 					-- So use tcMatch instead
 	    tcMatch the_match			`thenTc`   \ (match', lie_match, match_ty) ->
-	    unifyTauTy match_ty expected_ty 	`thenTc_`
+	    unifyTauTy expected_ty match_ty 	`thenTc_`
 	    returnTc (match', lie_match)
 
 	Just (arg_ty,rest_ty) ->	-- It's a function type!
@@ -140,7 +140,7 @@ tcMatchExpected expected_ty the_match@(PatMatch pat match)
 	    in
 	    newMonoIds binders mkTypeKind (\ _ ->
 		tcPat pat			`thenTc` \ (pat', lie_pat, pat_ty) ->
-		unifyTauTy arg_ty pat_ty	`thenTc_`
+		unifyTauTy pat_ty arg_ty	`thenTc_`
 		tcMatchExpected rest_ty  match	`thenTc` \ (match', lie_match) ->
 		returnTc (PatMatch pat' match',
 			  plusLIE lie_pat lie_match)
@@ -148,7 +148,7 @@ tcMatchExpected expected_ty the_match@(PatMatch pat match)
 
 tcMatchExpected expected_ty (GRHSMatch grhss_and_binds)
   = tcGRHSsAndBinds grhss_and_binds   	`thenTc` \ (grhss_and_binds', lie, grhss_ty) ->
-    unifyTauTy grhss_ty expected_ty 	`thenTc_`
+    unifyTauTy expected_ty grhss_ty 	`thenTc_`
     returnTc (GRHSMatch grhss_and_binds', lie)
 
 tcMatch	:: RenamedMatch -> TcM s (TcMatch s, LIE s, TcType s)
diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs
index 9d7b16d83e..077b0791ef 100644
--- a/ghc/compiler/typecheck/TcModule.lhs
+++ b/ghc/compiler/typecheck/TcModule.lhs
@@ -34,6 +34,7 @@ import TcDefaults	( tcDefaults )
 import TcEnv		( tcExtendGlobalValEnv, getEnv_LocalIds,
 			  getEnv_TyCons, getEnv_Classes,
 			  tcLookupLocalValueByKey, tcLookupTyConByKey )
+import SpecEnv		( SpecEnv )
 import TcIfaceSig	( tcInterfaceSigs )
 import TcInstDcls	( tcInstDecls1, tcInstDecls2 )
 import TcInstUtil	( buildInstanceEnvs, InstInfo )
diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs
index a81a1125b9..046ab6de26 100644
--- a/ghc/compiler/typecheck/TcPat.lhs
+++ b/ghc/compiler/typecheck/TcPat.lhs
@@ -23,6 +23,7 @@ import Inst		( Inst, OverloadedLit(..), InstOrigin(..),
 			)
 import TcEnv		( tcLookupGlobalValue, tcLookupGlobalValueByKey, 
 			  tcLookupLocalValueOK )
+import SpecEnv		( SpecEnv )
 import TcType 		( SYN_IE(TcType), TcMaybe, newTyVarTy, newTyVarTys, tcInstId )
 import Unify 		( unifyTauTy, unifyTauTyList, unifyTauTyLists )
 
@@ -341,7 +342,7 @@ matchConArgTys con arg_tys
     checkTc (con_arity == no_of_args)
 	    (arityErr "Constructor" con_id con_arity no_of_args)	`thenTc_`
 
-    unifyTauTyLists arg_tys con_args	 				`thenTc_`
+    unifyTauTyLists con_args arg_tys	 				`thenTc_`
     returnTc (con_id, con_result)
 \end{code}
 
diff --git a/ghc/compiler/typecheck/TcPragmas.lhs b/ghc/compiler/typecheck/TcPragmas.lhs
index e28f90a809..065215247a 100644
--- a/ghc/compiler/typecheck/TcPragmas.lhs
+++ b/ghc/compiler/typecheck/TcPragmas.lhs
@@ -179,7 +179,7 @@ tc_strictness
 	-> Maybe Type
 	-> Id		-- final Id (do not *touch*)
 	-> ImpStrictness Name
-	-> Baby_TcM (StrictnessInfo, UnfoldingDetails)
+	-> Baby_TcM (StrictnessInfo, Unfolding)
 
 tc_strictness e ty_maybe rec_final_id info
   = getSwitchCheckerB_Tc    `thenB_Tc` \ sw_chkr ->
@@ -359,7 +359,7 @@ tc_unfolding e (ImpUnfolding guidance uf_core)
 	-- NB: We cant check the lint result and return noInfo_UF if
 	--     lintUnfolding failed as this is too strict
 	--     Instead getInfo_UF tests for BadUnfolding and converts
-	--     to NoUnfoldingDetails when the unfolding is accessed
+	--     to NoUnfolding when the unfolding is accessed
 
 	maybe_lint_expr = lintUnfolding locn core_expr
 
diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs
index e6fc6890fe..f9ac4f305c 100644
--- a/ghc/compiler/typecheck/TcSimplify.lhs
+++ b/ghc/compiler/typecheck/TcSimplify.lhs
@@ -29,6 +29,7 @@ import Inst		( lookupInst, lookupSimpleInst,
 			  plusLIE, unitLIE, consLIE, InstOrigin(..),
 			  OverloadedLit )
 import TcEnv		( tcGetGlobalTyVars )
+import SpecEnv		( SpecEnv )
 import TcType		( SYN_IE(TcType), SYN_IE(TcTyVar), SYN_IE(TcTyVarSet), TcMaybe, tcInstType )
 import Unify		( unifyTauTy )
 
@@ -686,7 +687,7 @@ disambigOne dict_infos
 	-- See if any default works, and if so bind the type variable to it
     try_default default_tys		`thenTc` \ chosen_default_ty ->
     tcInstType [] chosen_default_ty	`thenNF_Tc` \ chosen_default_tc_ty ->	-- Tiresome!
-    unifyTauTy (mkTyVarTy tyvar) chosen_default_tc_ty
+    unifyTauTy chosen_default_tc_ty (mkTyVarTy tyvar)
 
   where
     (_,_,tyvar) = head dict_infos		-- Should be non-empty
diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs
index 78417f8e70..d4d3c25c47 100644
--- a/ghc/compiler/typecheck/TcTyClsDecls.lhs
+++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs
@@ -25,6 +25,7 @@ import Inst		( SYN_IE(InstanceMapper) )
 import TcClassDcl	( tcClassDecl1 )
 import TcEnv		( tcExtendTyConEnv, tcExtendClassEnv,
 			  tcTyVarScope )
+import SpecEnv		( SpecEnv )
 import TcKind		( TcKind, newKindVars )
 import TcTyDecls	( tcTyDecl, mkDataBinds )
 
diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs
index 588c8b4cbf..4ae211d7c4 100644
--- a/ghc/compiler/types/Type.lhs
+++ b/ghc/compiler/types/Type.lhs
@@ -736,30 +736,38 @@ types.
 matchTy :: GenType t1 u1		-- Template
 	-> GenType t2 u2		-- Proposed instance of template
 	-> Maybe [(t1,GenType t2 u2)]	-- Matching substitution
+					
 
 matchTys :: [GenType t1 u1]		-- Templates
 	 -> [GenType t2 u2]		-- Proposed instance of template
-	 -> Maybe [(t1,GenType t2 u2)]	-- Matching substitution
+	 -> Maybe ([(t1,GenType t2 u2)],-- Matching substitution
+		   [GenType t2 u2])	-- Left over instance types
+
+matchTy  ty1  ty2  = match  ty1 ty2 (\s -> Just s) []
+matchTys tys1 tys2 = go [] tys1 tys2
+		   where
+		     go s [] 	    tys2        = Just (s,tys2)
+		     go s (ty1:tys1) []	        = panic "matchTys"
+		     go s (ty1:tys1) (ty2:tys2) = match ty1 ty2 (\s' -> go s' tys1 tys2) s
+						    
 
-matchTy  ty1  ty2  = match  [] [] ty1 ty2
-matchTys tys1 tys2 = match' [] (zipEqual "matchTys" tys1 tys2)
 \end{code}
 
 @match@ is the main function.
 
 \begin{code}
-match :: [(t1, GenType t2 u2)]			-- r, the accumulating result
-      -> [(GenType t1 u1, GenType t2 u2)]	-- w, the work list
-      -> GenType t1 u1 -> GenType t2 u2		-- Current match pair
-      -> Maybe [(t1, GenType t2 u2)]
-
-match r w (TyVarTy v) 	       ty		    = match' ((v,ty) : r) w
-match r w (FunTy fun1 arg1 _)  (FunTy fun2 arg2 _)  = match r ((fun1,fun2):w) arg1 arg2
-match r w (AppTy fun1 arg1)  (AppTy fun2 arg2)      = match r ((fun1,fun2):w) arg1 arg2
-match r w (TyConTy con1 _)     (TyConTy con2 _)     | con1  == con2  = match' r w
-match r w (DictTy clas1 ty1 _) (DictTy clas2 ty2 _) | clas1 == clas2 = match r w ty1 ty2
-match r w (SynTy _ _ ty1)      ty2		    = match r w ty1 ty2
-match r w ty1		       (SynTy _ _ ty2)      = match r w ty1 ty2
+match :: GenType t1 u1 -> GenType t2 u2			-- Current match pair
+      -> ([(t1, GenType t2 u2)] -> Maybe result)	-- Continuation
+      -> [(t1, GenType t2 u2)]				-- Current substitution
+      -> Maybe result
+
+match (TyVarTy v) 	   ty		        k = \s -> k ((v,ty) : s)
+match (FunTy fun1 arg1 _)  (FunTy fun2 arg2 _)  k = match fun1 fun2 (match arg1 arg2 k)
+match (AppTy fun1 arg1)    (AppTy fun2 arg2)    k = match fun1 fun2 (match arg1 arg2 k)
+match (TyConTy con1 _)     (TyConTy con2 _)     k | con1  == con2  = k
+match (DictTy clas1 ty1 _) (DictTy clas2 ty2 _) k | clas1 == clas2 = match ty1 ty2 k
+match (SynTy _ _ ty1)      ty2		        k = match ty1 ty2 k
+match ty1		       (SynTy _ _ ty2)  k = match ty1 ty2 k
 
 	-- With type synonyms, we have to be careful for the exact
 	-- same reasons as in the unifier.  Please see the
@@ -767,10 +775,7 @@ match r w ty1		       (SynTy _ _ ty2)      = match r w ty1 ty2
 	-- here! (WDP 95/05)
 
 -- Catch-all fails
-match _ _ _ _ = Nothing
-
-match' r [] 	       = Just r
-match' r ((ty1,ty2):w) = match r w ty1 ty2
+match _ _ _ = \s -> Nothing
 \end{code}
 
 %************************************************************************
diff --git a/ghc/compiler/utils/Ubiq.lhi b/ghc/compiler/utils/Ubiq.lhi
index 97c7b3193f..0ffea8b5f4 100644
--- a/ghc/compiler/utils/Ubiq.lhi
+++ b/ghc/compiler/utils/Ubiq.lhi
@@ -16,7 +16,7 @@ import CmdLineOpts	( SimplifierSwitch, SwitchResult )
 import CoreSyn		( GenCoreArg, GenCoreBinder, GenCoreBinding, GenCoreExpr,
 			  GenCoreCaseAlts, GenCoreCaseDefault, Coercion
 			)
-import CoreUnfold	( UnfoldingDetails, UnfoldingGuidance )
+import CoreUnfold	( Unfolding, UnfoldingGuidance )
 import CostCentre	( CostCentre )
 import FieldLabel	( FieldLabel )
 import FiniteMap	( FiniteMap )
@@ -133,7 +133,7 @@ data UnfoldingCoreExpr a
 data UniqFM a
 data UpdateInfo
 data UniqSupply
-data UnfoldingDetails
+data Unfolding
 data UnfoldingGuidance
 data Unique	-- NB: fails the optimisation criterion
 
diff --git a/ghc/compiler/utils/Ubiq_1_3.lhi b/ghc/compiler/utils/Ubiq_1_3.lhi
index 2636612961..77ce05a469 100644
--- a/ghc/compiler/utils/Ubiq_1_3.lhi
+++ b/ghc/compiler/utils/Ubiq_1_3.lhi
@@ -21,7 +21,7 @@ Class Class
 ClosureInfo ClosureInfo
 CmdLineOpts SwitchResult
 CoreSyn GenCoreExpr
-CoreUnfold UnfoldingDetails
+CoreUnfold Unfolding
 CoreUnfold UnfoldingGuidance
 CostCentre CostCentre
 HeapOffs HeapOffset
diff --git a/ghc/compiler/utils/UniqFM.lhs b/ghc/compiler/utils/UniqFM.lhs
index 09723c824e..6374705f25 100644
--- a/ghc/compiler/utils/UniqFM.lhs
+++ b/ghc/compiler/utils/UniqFM.lhs
@@ -28,12 +28,10 @@ module UniqFM (
 	unitDirectlyUFM,
 	listToUFM,
 	listToUFM_Directly,
-	addToUFM,
-	addListToUFM,
+	addToUFM,addToUFM_C,
+	addListToUFM,addListToUFM_C,
 	addToUFM_Directly,
 	addListToUFM_Directly,
-	IF_NOT_GHC(addToUFM_C COMMA)
-	addListToUFM_C,
 	delFromUFM,
 	delFromUFM_Directly,
 	delListFromUFM,