diff --git a/ghc/compiler/basicTypes/Const.lhs b/ghc/compiler/basicTypes/Const.lhs
index d1e1a5dc0562897efc0aaaaad08a276b7db5f9fa..7348a0dcd03cb8daa8376e596f2013d14e1cd9c4 100644
--- a/ghc/compiler/basicTypes/Const.lhs
+++ b/ghc/compiler/basicTypes/Const.lhs
@@ -9,7 +9,7 @@ module Const (
 	conType, conPrimRep,
 	conOkForApp, conOkForAlt, isWHNFCon, isDataCon,
 	conIsTrivial, conIsCheap, conIsDupable, conStrictness, 
-	conOkForSpeculation,
+	conOkForSpeculation, hashCon,
 
 	DataCon, PrimOp,	-- For completeness
 
@@ -27,10 +27,11 @@ module Const (
 import TysPrim		( charPrimTy, addrPrimTy, floatPrimTy, doublePrimTy,
 			  intPrimTy, wordPrimTy, int64PrimTy, word64PrimTy
 			)
-import PrimOp		( PrimOp, primOpType, primOpIsDupable,
+import Name		( hashName )
+import PrimOp		( PrimOp, primOpType, primOpIsDupable, primOpTag,
 			  primOpIsCheap, primOpStrictness, primOpOkForSpeculation )
 import PrimRep		( PrimRep(..) )
-import DataCon		( DataCon, dataConType, dataConTyCon, isNullaryDataCon, dataConRepStrictness )
+import DataCon		( DataCon, dataConName, dataConType, dataConTyCon, isNullaryDataCon, dataConRepStrictness )
 import TyCon		( isNewTyCon )
 import Type		( Type, typePrimRep )
 import PprType		( pprParendType )
@@ -41,6 +42,8 @@ import Outputable
 import Util		( thenCmp )
 
 import Ratio 		( numerator, denominator )
+import FastString	( uniqueOfFS )
+import Char		( ord )
 \end{code}
 
 
@@ -185,7 +188,6 @@ data Literal
 			-- thin air.    Integer is, so the type here is really redundant.
 \end{code}
 
-
 \begin{code}
 instance Outputable Literal where
     ppr lit = pprLit lit
@@ -374,3 +376,44 @@ pprLit lit
 						    pprFSAsString s,
 						    pprParendType ty])
 \end{code}
+
+
+%************************************************************************
+%*									*
+\subsection{Hashing
+%*									*
+%************************************************************************
+
+Hash values should be zero or a positive integer.  No negatives please.
+(They mess up the UniqFM for some reason.)
+
+\begin{code}
+hashCon :: Con -> Int
+hashCon (DataCon dc)  = hashName (dataConName dc)
+hashCon (PrimOp op)   = primOpTag op + 500	-- Keep it out of range of common ints
+hashCon (Literal lit) = hashLiteral lit
+hashCon other	      = pprTrace "hashCon" (ppr other) 0
+
+hashLiteral :: Literal -> Int
+hashLiteral (MachChar c)    	= ord c + 1000	-- Keep it out of range of common ints
+hashLiteral (MachStr s)     	= hashFS s
+hashLiteral (MachAddr i)    	= hashInteger i
+hashLiteral (MachInt i _)   	= hashInteger i
+hashLiteral (MachInt64 i _) 	= hashInteger i
+hashLiteral (MachFloat r)   	= hashRational r
+hashLiteral (MachDouble r)  	= hashRational r
+hashLiteral (MachLitLit s _)    = hashFS s
+hashLiteral (NoRepStr s _)      = hashFS s
+hashLiteral (NoRepInteger i _)  = hashInteger i
+hashLiteral (NoRepRational r _) = hashRational r
+
+hashRational :: Rational -> Int
+hashRational r = hashInteger (numerator r)
+
+hashInteger :: Integer -> Int
+hashInteger i = abs (fromInteger (i `rem` 10000))
+
+hashFS :: FAST_STRING -> Int
+hashFS s = IBOX( uniqueOfFS s )
+\end{code}
+
diff --git a/ghc/compiler/basicTypes/IdInfo.lhs b/ghc/compiler/basicTypes/IdInfo.lhs
index 993f21030fdf7f3007e6888b59e495012e8e7689..4b32253e1b49cb76c5ee67ade9bf5a5983a85392 100644
--- a/ghc/compiler/basicTypes/IdInfo.lhs
+++ b/ghc/compiler/basicTypes/IdInfo.lhs
@@ -658,10 +658,11 @@ noLBVarInfo = NoLBVarInfo
 
 -- not safe to print or parse LBVarInfo because it is not really a
 -- property of the definition, but a property of the context.
-ppLBVarInfo _ = empty
+pprLBVarInfo NoLBVarInfo     = empty
+pprLBVarInfo IsOneShotLambda = ptext SLIT("OneShot")
 
 instance Outputable LBVarInfo where
-    ppr = ppLBVarInfo
+    ppr = pprLBVarInfo
 
 instance Show LBVarInfo where
     showsPrec p c = showsPrecSDoc p (ppr c)
diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs
index 59b0510cd88f77bceee7db72d82fd6dbbe064bb6..77098685c16a0930a35785dbd48cb219443118bd 100644
--- a/ghc/compiler/basicTypes/Name.lhs
+++ b/ghc/compiler/basicTypes/Name.lhs
@@ -15,7 +15,7 @@ module Name (
 	mkDerivedName, mkGlobalName, mkKnownKeyGlobal,
 	mkWiredInIdName,   mkWiredInTyConName,
 	maybeWiredInIdName, maybeWiredInTyConName,
-	isWiredInName,
+	isWiredInName, hashName,
 
 	nameUnique, setNameUnique, setNameProvenance, getNameProvenance, setNameImportReason,
 	tidyTopName, 
@@ -30,7 +30,7 @@ module Name (
 	-- Provenance
 	Provenance(..), ImportReason(..), pprProvenance,
 	ExportFlag(..), PrintUnqualified,
-        pprNameProvenance, systemProvenance, hasBetterProv,
+        pprNameProvenance, hasBetterProv,
 
 	-- Class NamedThing and overloaded friends
 	NamedThing(..),
@@ -48,7 +48,7 @@ import RdrName		( RdrName, mkRdrQual, mkRdrUnqual, rdrNameOcc, rdrNameModule )
 import CmdLineOpts	( opt_PprStyle_NoPrags, opt_OmitInterfacePragmas, opt_EnsureSplittableC )
 
 import SrcLoc		( noSrcLoc, mkBuiltinSrcLoc, SrcLoc )
-import Unique		( pprUnique, Unique, Uniquable(..) )
+import Unique		( pprUnique, Unique, Uniquable(..), u2i )
 import Outputable
 import GlaExts
 \end{code}
@@ -116,7 +116,7 @@ mkKnownKeyGlobal (rdr_name, uniq)
 
 mkSysLocalName :: Unique -> FAST_STRING -> Name
 mkSysLocalName uniq fs = Name { n_uniq = uniq, n_sort = Local, 
-				n_occ = mkSrcVarOcc fs, n_prov = SystemProv }
+				n_occ = mkSrcVarOcc fs, n_prov = systemProvenance }
 
 mkTopName :: Unique -> Module -> FAST_STRING -> Name
 	-- Make a top-level name; make it Global if top-level
@@ -376,6 +376,9 @@ isExternallyVisibleName :: Name -> Bool
 
 
 
+hashName :: Name -> Int
+hashName name = IBOX( u2i (nameUnique name) )
+
 nameUnique name = n_uniq name
 nameOccName name = n_occ name
 
diff --git a/ghc/compiler/codeGen/CgCase.lhs b/ghc/compiler/codeGen/CgCase.lhs
index 6b7f9f2e985dca2860e12369c2361601bd18becc..9eb6b22160c4ab5b7c5cf677e42e2cddbc720d3c 100644
--- a/ghc/compiler/codeGen/CgCase.lhs
+++ b/ghc/compiler/codeGen/CgCase.lhs
@@ -1,7 +1,7 @@
 %
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
-% $Id: CgCase.lhs,v 1.31 1999/06/09 14:27:38 simonmar Exp $
+% $Id: CgCase.lhs,v 1.32 1999/06/22 07:59:59 simonpj Exp $
 %
 %********************************************************
 %*							*
@@ -745,7 +745,8 @@ cgPrimInlineAlts bndr ty alts deflt
 cgPrimEvalAlts bndr ty alts deflt
   = cgPrimAltsWithDefault bndr GCMayHappen (CReg reg) alts deflt [reg]
   where
-	reg = dataReturnConvPrim kind
+	reg  = WARN( case kind of { PtrRep -> True; other -> False }, text "cgPrimEE" <+> ppr bndr <+> ppr ty  )
+	       dataReturnConvPrim kind
 	kind = typePrimRep ty
 
 cgPrimAltsWithDefault bndr gc_flag scrutinee alts deflt regs
diff --git a/ghc/compiler/codeGen/CgTailCall.lhs b/ghc/compiler/codeGen/CgTailCall.lhs
index e98f66b39a41cb7c38ab65c3c05ee8e8f3266bd2..c33c649d924968295e4908804f0d443e033bcaee 100644
--- a/ghc/compiler/codeGen/CgTailCall.lhs
+++ b/ghc/compiler/codeGen/CgTailCall.lhs
@@ -1,7 +1,7 @@
 %
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
-% $Id: CgTailCall.lhs,v 1.21 1999/06/08 15:56:48 simonmar Exp $
+% $Id: CgTailCall.lhs,v 1.22 1999/06/22 08:00:00 simonpj Exp $
 %
 %********************************************************
 %*							*
@@ -28,6 +28,7 @@ module CgTailCall (
 
 import CgMonad
 import AbsCSyn
+import PprAbsC		( pprAmode )
 
 import AbsCUtils	( mkAbstractCs, mkAbsCStmts, getAmodeRep )
 import CgBindery	( getArgAmodes, getCAddrMode, getCAddrModeAndInfo )
@@ -118,7 +119,8 @@ performPrimReturn :: SDoc	-- Just for debugging (sigh)
 performPrimReturn doc amode
   = let
 	kind = getAmodeRep amode
-	ret_reg = dataReturnConvPrim kind
+	ret_reg = WARN( case kind of { PtrRep -> True; other -> False }, text "primRet" <+> doc <+> pprAmode amode )
+		  dataReturnConvPrim kind
 
 	assign_possibly = case kind of
 	  VoidRep -> AbsCNop
diff --git a/ghc/compiler/coreSyn/CoreUnfold.hi-boot b/ghc/compiler/coreSyn/CoreUnfold.hi-boot
index 212b50d7bbc59e0010bba6e89c5beb456f48797e..e670f2dcb7f0ab92d9804fbdef5bc3b61c8ff3dd 100644
--- a/ghc/compiler/coreSyn/CoreUnfold.hi-boot
+++ b/ghc/compiler/coreSyn/CoreUnfold.hi-boot
@@ -1,9 +1,10 @@
 _interface_ CoreUnfold 1
 _exports_
-CoreUnfold Unfolding UnfoldingGuidance mkUnfolding noUnfolding hasUnfolding;
+CoreUnfold Unfolding UnfoldingGuidance mkUnfolding noUnfolding hasUnfolding isEvaldUnfolding;
 _declarations_
 1 data Unfolding;
 1 data UnfoldingGuidance;
 1 mkUnfolding _:_ CoreSyn.CoreExpr -> Unfolding ;;
 1 noUnfolding _:_ Unfolding ;;
 1 hasUnfolding _:_ Unfolding -> PrelBase.Bool ;;
+1 isEvaldUnfolding _:_ Unfolding -> PrelBase.Bool ;;
diff --git a/ghc/compiler/coreSyn/CoreUnfold.hi-boot-5 b/ghc/compiler/coreSyn/CoreUnfold.hi-boot-5
index ce4927bca32ae17c24298ff3ae40042442967af0..d86aa996ca5436d8f59232faef1427a63dffcaa2 100644
--- a/ghc/compiler/coreSyn/CoreUnfold.hi-boot-5
+++ b/ghc/compiler/coreSyn/CoreUnfold.hi-boot-5
@@ -1,7 +1,8 @@
 __interface CoreUnfold 1 0 where
-__export CoreUnfold Unfolding UnfoldingGuidance mkUnfolding noUnfolding hasUnfolding;
+__export CoreUnfold Unfolding UnfoldingGuidance mkUnfolding noUnfolding hasUnfolding isEvaldUnfolding;
 1 data Unfolding;
 1 data UnfoldingGuidance;
 1 mkUnfolding :: CoreSyn.CoreExpr -> Unfolding ;
 1 noUnfolding :: Unfolding ;
 1 hasUnfolding :: Unfolding -> PrelBase.Bool ;
+1 isEvaldUnfolding :: Unfolding -> PrelBase.Bool ;
diff --git a/ghc/compiler/coreSyn/CoreUnfold.lhs b/ghc/compiler/coreSyn/CoreUnfold.lhs
index 39740c79387159eafa8d047c1da32654cfaaccf3..6fd0fd9b4db127dafed044a513f09f64197e1df8 100644
--- a/ghc/compiler/coreSyn/CoreUnfold.lhs
+++ b/ghc/compiler/coreSyn/CoreUnfold.lhs
@@ -14,10 +14,13 @@ find, unsurprisingly, a Core expression.
 
 \begin{code}
 module CoreUnfold (
-	Unfolding(..), UnfoldingGuidance, -- types
+	Unfolding, UnfoldingGuidance, -- types
 
-	noUnfolding, mkUnfolding, getUnfoldingTemplate,
-	isEvaldUnfolding, hasUnfolding,
+	noUnfolding, mkUnfolding, 
+	mkOtherCon, otherCons,
+	unfoldingTemplate, maybeUnfoldingTemplate,
+	isEvaldUnfolding, isCheapUnfolding,
+	hasUnfolding,
 
 	couldBeSmallEnoughToInline, 
 	certainlySmallEnoughToInline, 
@@ -44,17 +47,17 @@ import CoreSyn
 import PprCore		( pprCoreExpr )
 import OccurAnal	( occurAnalyseGlobalExpr )
 import BinderInfo	( )
-import CoreUtils	( coreExprType, exprIsTrivial, mkFormSummary, whnfOrBottom,
-			  FormSummary(..) )
+import CoreUtils	( coreExprType, exprIsTrivial, exprIsValue, exprIsCheap )
 import Id		( Id, idType, idUnique, isId, 
 			  getIdSpecialisation, getInlinePragma, getIdUnfolding
 			)
 import VarSet
+import Name		( isLocallyDefined )
 import Const		( Con(..), isLitLitLit, isWHNFCon )
 import PrimOp		( PrimOp(..), primOpIsDupable )
 import IdInfo		( ArityInfo(..), InlinePragInfo(..), OccInfo(..) )
 import TyCon		( tyConFamilySize )
-import Type		( splitAlgTyConApp_maybe, splitFunTy_maybe )
+import Type		( splitAlgTyConApp_maybe, splitFunTy_maybe, isUnLiftedType )
 import Const		( isNoRepLit )
 import Unique		( Unique, buildIdKey, augmentIdKey, runSTRepIdKey )
 import Maybes		( maybeToBool )
@@ -83,34 +86,51 @@ data Unfolding
 				-- Here, f gets an OtherCon [] unfolding.
 
   | CoreUnfolding			-- An unfolding with redundant cached information
-		FormSummary		-- Tells whether the template is a WHNF or bottom
-		UnfoldingGuidance	-- Tells about the *size* of the template.
 		CoreExpr		-- Template; binder-info is correct
+		Bool			-- exprIsCheap template (cached); it won't duplicate (much) work 
+					--	if you inline this in more than one place
+		Bool			-- exprIsValue template (cached); it is ok to discard a `seq` on
+					--	this variable
+		UnfoldingGuidance	-- Tells about the *size* of the template.
 \end{code}
 
 \begin{code}
 noUnfolding = NoUnfolding
+mkOtherCon  = OtherCon
 
 mkUnfolding expr
-  = let
-     -- strictness mangling (depends on there being no CSE)
-     ufg = calcUnfoldingGuidance opt_UF_CreationThreshold expr
-     occ = occurAnalyseGlobalExpr expr
-    in
-    CoreUnfolding (mkFormSummary expr) ufg occ
+  = CoreUnfolding (occurAnalyseGlobalExpr expr)
+		  (exprIsCheap expr)
+		  (exprIsValue expr)
+		  (calcUnfoldingGuidance opt_UF_CreationThreshold expr)
+
+unfoldingTemplate :: Unfolding -> CoreExpr
+unfoldingTemplate (CoreUnfolding expr _ _ _) = expr
+unfoldingTemplate other = panic "getUnfoldingTemplate"
+
+maybeUnfoldingTemplate :: Unfolding -> Maybe CoreExpr
+maybeUnfoldingTemplate (CoreUnfolding expr _ _ _) = Just expr
+maybeUnfoldingTemplate other 			  = Nothing
 
-getUnfoldingTemplate :: Unfolding -> CoreExpr
-getUnfoldingTemplate (CoreUnfolding _ _ expr) = expr
-getUnfoldingTemplate other = panic "getUnfoldingTemplate"
+otherCons (OtherCon cons) = cons
+otherCons other		  = []
 
 isEvaldUnfolding :: Unfolding -> Bool
-isEvaldUnfolding (OtherCon _)		          = True
-isEvaldUnfolding (CoreUnfolding ValueForm _ expr) = True
-isEvaldUnfolding other			          = False
+isEvaldUnfolding (OtherCon _)		        = True
+isEvaldUnfolding (CoreUnfolding _ _ is_evald _) = is_evald
+isEvaldUnfolding other			        = False
+
+isCheapUnfolding :: Unfolding -> Bool
+isCheapUnfolding (CoreUnfolding _ is_cheap _ _) = is_cheap
+isCheapUnfolding other				= False
 
 hasUnfolding :: Unfolding -> Bool
-hasUnfolding NoUnfolding = False
-hasUnfolding other 	 = True
+hasUnfolding (CoreUnfolding _ _ _ _) = True
+hasUnfolding other 	 	     = False
+
+hasSomeUnfolding :: Unfolding -> Bool
+hasSomeUnfolding NoUnfolding = False
+hasSomeUnfolding other	     = True
 
 data UnfoldingGuidance
   = UnfoldNever
@@ -232,7 +252,9 @@ sizeExpr (I# bOMB_OUT_SIZE) args expr
     size_up (Let (NonRec binder rhs) body)
       = nukeScrutDiscount (size_up rhs)		`addSize`
 	size_up body				`addSizeN`
-	1	-- For the allocation
+	(if isUnLiftedType (idType binder) then 0 else 1)
+		-- For the allocation
+		-- If the binder has an unlifted type there is no allocation
 
     size_up (Let (Rec pairs) body)
       = nukeScrutDiscount rhs_size		`addSize`
@@ -244,10 +266,13 @@ sizeExpr (I# bOMB_OUT_SIZE) args expr
     size_up (Case scrut _ alts)
       = nukeScrutDiscount (size_up scrut)		`addSize`
 	arg_discount scrut				`addSize`
-	foldr (addSize . size_up_alt) sizeZero alts	`addSizeN`
-	case (splitAlgTyConApp_maybe (coreExprType scrut)) of
-	      	Nothing       -> 1
-	      	Just (tc,_,_) -> tyConFamilySize tc
+	foldr (addSize . size_up_alt) sizeZero alts	
+
+-- Just charge for the alts that exist, not the ones that might exist
+--	`addSizeN`
+--	case (splitAlgTyConApp_maybe (coreExprType scrut)) of
+--	      	Nothing       -> 1
+--	      	Just (tc,_,_) -> tyConFamilySize tc
 
     ------------ 
     size_up_app (App fun arg) args   = size_up_app fun (arg:args)
@@ -256,7 +281,8 @@ sizeExpr (I# bOMB_OUT_SIZE) args expr
 	-- A function application with at least one value argument
 	-- so if the function is an argument give it an arg-discount
 	-- Also behave specially if the function is a build
-    fun_discount (Var fun) | idUnique fun == buildIdKey = buildSize
+    fun_discount (Var fun) | idUnique fun == buildIdKey   = buildSize
+    			   | idUnique fun == augmentIdKey = augmentSize
     			   | fun `is_elem` args 	= scrutArg fun
     fun_discount other					= sizeZero
 
@@ -332,8 +358,12 @@ buildSize = SizeIs (-2#) emptyBag 4#
 	-- build t (\cn -> e) should cost only the cost of e (because build will be inlined later)
 	-- Indeed, we should add a result_discount becuause build is 
 	-- very like a constructor.  We don't bother to check that the
-	-- build is saturated (it usually is).  The "-2" discounts for the \c n
+	-- build is saturated (it usually is).  The "-2" discounts for the \c n, 
 	-- The "4" is rather arbitrary.
+
+augmentSize = SizeIs (-2#) emptyBag 4#
+	-- Ditto (augment t (\cn -> e) ys) should cost only the cost of
+	-- e plus ys. The -2 accounts for the \cn 
 						
 scrutArg v	= SizeIs 0# (unitBag v) 0#
 
@@ -450,7 +480,7 @@ callSiteInline black_listed inline_call id args interesting_cont
   = case getIdUnfolding id of {
 	NoUnfolding -> Nothing ;
 	OtherCon _  -> Nothing ;
-	CoreUnfolding form guidance unf_template ->
+	CoreUnfolding unf_template is_cheap _ guidance ->
 
     let
 	result | yes_or_no = Just unf_template
@@ -459,7 +489,6 @@ callSiteInline black_listed inline_call id args interesting_cont
 	inline_prag = getInlinePragma id
 	arg_infos   = map interestingArg val_args
 	val_args    = filter isValArg args
-	whnf	    = whnfOrBottom form
 
 	yes_or_no =
 	    case inline_prag of
@@ -467,22 +496,22 @@ callSiteInline black_listed inline_call id args interesting_cont
 		IMustNotBeINLINEd -> False
 		IAmALoopBreaker   -> False
 		IMustBeINLINEd    -> True	-- Overrides absolutely everything, including the black list
-		ICanSafelyBeINLINEd in_lam one_br -> consider in_lam    one_br
-		NoInlinePragInfo		  -> consider InsideLam False
+		ICanSafelyBeINLINEd in_lam one_br -> consider in_lam    True  one_br
+		NoInlinePragInfo		  -> consider InsideLam False False
 
-	consider in_lam one_branch 
+	consider in_lam once once_in_one_branch
 	  | black_listed = False
 	  | inline_call  = True
-	  | one_branch	-- Be very keen to inline something if this is its unique occurrence; that
-			-- gives a good chance of eliminating the original binding for the thing.
-			-- The only time we hold back is when substituting inside a lambda;
-			-- then if the context is totally uninteresting (not applied, not scrutinised)
-			-- there is no point in substituting because it might just increase allocation.
+	  | once_in_one_branch	-- Be very keen to inline something if this is its unique occurrence; that
+				-- gives a good chance of eliminating the original binding for the thing.
+				-- The only time we hold back is when substituting inside a lambda;
+				-- then if the context is totally uninteresting (not applied, not scrutinised)
+				-- there is no point in substituting because it might just increase allocation.
 	  = WARN( case in_lam of { NotInsideLam -> True; other -> False },
 		  text "callSiteInline:oneOcc" <+> ppr id )
 		-- If it has one occurrence, not inside a lambda, PreInlineUnconditionally
 		-- should have zapped it already
-	    whnf && (not (null args) || interesting_cont)
+	    is_cheap && (not (null args) || interesting_cont)
 
 	  | otherwise	-- Occurs (textually) more than once, so look at its size
 	  = case guidance of
@@ -494,17 +523,20 @@ callSiteInline black_listed inline_call id args interesting_cont
 			-- Size of call is n_vals_wanted (+1 for the function)
 		-> case in_lam of
 			NotInsideLam -> True
-			InsideLam    -> whnf
+			InsideLam    -> is_cheap
 
-		| not (or arg_infos || really_interesting_cont)
+		| not (or arg_infos || really_interesting_cont || once)
 			-- If it occurs more than once, there must be something interesting 
 			-- about some argument, or the result, to make it worth inlining
+			-- We also drop this case if the thing occurs once, although perhaps in 
+			-- several branches.  In this case we are keener about inlining in the hope
+			-- that we'll be able to drop the allocation for the function altogether.
 		-> False
   
 		| otherwise
 		-> case in_lam of
 			NotInsideLam -> small_enough
-			InsideLam    -> whnf && small_enough
+			InsideLam    -> is_cheap && small_enough
 
 		where
 		  n_args		  = length arg_infos
@@ -531,7 +563,7 @@ callSiteInline black_listed inline_call id args interesting_cont
 				   text "inline prag:" <+> ppr inline_prag,
 			  	   text "arg infos" <+> ppr arg_infos,
 				   text "interesting continuation" <+> ppr interesting_cont,
-				   text "whnf" <+> ppr whnf,
+				   text "is cheap" <+> ppr is_cheap,
 				   text "guidance" <+> ppr guidance,
 				   text "ANSWER =" <+> if yes_or_no then text "YES" else text "NO",
 				   if yes_or_no then
@@ -550,7 +582,7 @@ callSiteInline black_listed inline_call id args interesting_cont
 -- There is little point in inlining f here.
 interestingArg (Type _)	         = False
 interestingArg (App fn (Type _)) = interestingArg fn
-interestingArg (Var v)	         = hasUnfolding (getIdUnfolding v)
+interestingArg (Var v)	         = hasSomeUnfolding (getIdUnfolding v)
 interestingArg other	         = True
 
 
@@ -604,9 +636,10 @@ blackListed :: IdSet 		-- Used in transformation rules
 -- inlined because of the inline phase we are in.  This is the sole
 -- place that the inline phase number is looked at.
 
--- Phase 0: used for 'no inlinings please'
+-- Phase 0: used for 'no imported inlinings please'
+-- This prevents wrappers getting inlined which in turn is bad for full laziness
 blackListed rule_vars (Just 0)
-  = \v -> True
+  = \v -> not (isLocallyDefined v)
 
 -- Phase 1: don't inline any rule-y things or things with specialisations
 blackListed rule_vars (Just 1)
diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs
index 49bbf151267d1c7c7560ec89fa8b98dd120c4dce..ea91fe4a31f4a85df565da375236b3082f1df481 100644
--- a/ghc/compiler/coreSyn/CoreUtils.lhs
+++ b/ghc/compiler/coreSyn/CoreUtils.lhs
@@ -7,26 +7,28 @@
 module CoreUtils (
 	coreExprType, coreAltsType,
 
-	exprIsBottom, exprIsDupable, exprIsTrivial, exprIsWHNF, exprIsCheap, exprIsValue,
-	exprOkForSpeculation,
-	FormSummary(..), mkFormSummary, whnfOrBottom, exprArity,
+	exprIsBottom, exprIsDupable, exprIsTrivial, exprIsCheap, exprIsValue,
+	exprOkForSpeculation, exprIsBig, hashExpr,
+	exprArity,
 	cheapEqExpr, eqExpr, applyTypeToArgs
     ) where
 
 #include "HsVersions.h"
 
 
+import {-# SOURCE #-} CoreUnfold	( isEvaldUnfolding )
+
 import CoreSyn
 import PprCore		( pprCoreExpr )
 import Var		( IdOrTyVar, isId, isTyVar )
 import VarSet
 import VarEnv
-import Name		( isLocallyDefined )
+import Name		( isLocallyDefined, hashName )
 import Const		( Con, isWHNFCon, conIsTrivial, conIsCheap, conIsDupable,
-			  conType, conOkForSpeculation, conStrictness
+			  conType, conOkForSpeculation, conStrictness, hashCon
 			)
 import Id		( Id, idType, setIdType, idUnique, idAppIsBottom,
-			  getIdArity,
+			  getIdArity, idName,
 			  getIdSpecialisation, setIdSpecialisation,
 			  getInlinePragma, setInlinePragma,
 			  getIdUnfolding, setIdUnfolding, idInfo
@@ -106,71 +108,6 @@ applyTypeToArgs e op_ty (other_arg : args)
 %*									*
 %************************************************************************
 
-\begin{code}
-data FormSummary
-  = VarForm		-- Expression is a variable (or scc var, etc)
-
-  | ValueForm		-- Expression is a value: i.e. a value-lambda,constructor, or literal
-			-- 	May 1999: I'm experimenting with allowing "cheap" non-values
-			--	here.
-
-  | 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 VarForm    = ptext SLIT("Var")
-   ppr ValueForm  = ptext SLIT("Value")
-   ppr BottomForm = ptext SLIT("Bot")
-   ppr OtherForm  = ptext SLIT("Other")
-
-whnfOrBottom :: FormSummary -> Bool
-whnfOrBottom VarForm    = True
-whnfOrBottom ValueForm  = True
-whnfOrBottom BottomForm = True
-whnfOrBottom OtherForm  = False
-\end{code}
-
-\begin{code}
-mkFormSummary :: CoreExpr -> FormSummary
-	-- Used exclusively by CoreUnfold.mkUnfolding
-	-- Returns ValueForm for cheap things, not just values
-mkFormSummary expr
-  = go (0::Int) expr	-- The "n" is the number of *value* arguments so far
-  where
-    go n (Con con _) | isWHNFCon con = ValueForm
-		     | otherwise     = OtherForm
-
-    go n (Note _ e)         = go n e
-
-    go n (Let (NonRec b r) e) | exprIsCheap r = go n e	-- let f = f' alpha in (f,g) 
-							-- should be treated as a value
-    go n (Let _            e) 		      = OtherForm
-
-	-- We want selectors to look like values
-	-- e.g.  case x of { (a,b) -> a }
-	-- should give a ValueForm, so that it will be inlined vigorously
-	-- [June 99. I can't remember why this is a good idea.  It means that
-	-- all overloading selectors get inlined at their usage sites, which is
-	-- not at all necessarily a good thing.  So I'm rescinding this decision for now.]
---    go n expr@(Case _ _ _) | exprIsCheap expr = ValueForm
-
-    go n expr@(Case _ _ _)  = OtherForm
-
-    go 0 (Lam x e) | isId x    = ValueForm	-- NB: \x.bottom /= bottom!
-    		   | otherwise = go 0 e
-    go n (Lam x e) | isId x    = go (n-1) e	-- Applied lambda
-		   | otherwise = go n e
-
-    go n (App fun (Type _)) = go n fun		-- Ignore type args
-    go n (App fun arg)      = go (n+1) fun
-
-    go n (Var f) | idAppIsBottom f n = BottomForm
-    go 0 (Var f)		     = VarForm
-    go n (Var f) | n < arityLowerBound (getIdArity f) = ValueForm
-		 | otherwise			      = OtherForm
-\end{code}
-
 @exprIsTrivial@	is true of expressions we are unconditionally 
 		happy to duplicate; simple variables and constants,
 		and type applications.
@@ -190,8 +127,12 @@ exprIsTrivial other	     = False
 
 
 @exprIsDupable@	is true of expressions that can be duplicated at a modest
-		cost in space.  This will only happen in different case
+		cost in code size.  This will only happen in different case
 		branches, so there's no issue about duplicating work.
+
+		That is, exprIsDupable returns True of (f x) even if
+		f is very very expensive to call.
+
 		Its only purpose is to avoid fruitless let-binding
 		and then inlining of case join points
 
@@ -215,10 +156,13 @@ dupAppSize = 4		-- Size of application we are prepared to duplicate
 it is obviously in weak head normal form, or is cheap to get to WHNF.
 [Note that that's not the same as exprIsDupable; an expression might be
 big, and hence not dupable, but still cheap.]
-By ``cheap'' we mean a computation we're willing to push inside a lambda 
-in order to bring a couple of lambdas together.  That might mean it gets
-evaluated more than once, instead of being shared.  The main examples of things
-which aren't WHNF but are ``cheap'' are:
+
+By ``cheap'' we mean a computation we're willing to:
+	push inside a lambda, or
+	inline at more than one place
+That might mean it gets evaluated more than once, instead of being
+shared.  The main examples of things which aren't WHNF but are
+``cheap'' are:
 
   * 	case e of
 	  pi -> ei
@@ -234,6 +178,8 @@ which aren't WHNF but are ``cheap'' are:
 
 	where op is a cheap primitive operator
 
+  *	error "foo"
+
 Notice that a variable is considered 'cheap': we can push it inside a lambda,
 because sharing will make sure it is only evaluated once.
 
@@ -244,9 +190,12 @@ exprIsCheap (Var _)         	= True
 exprIsCheap (Con con args)  	= conIsCheap con && all exprIsCheap args
 exprIsCheap (Note _ e)      	= exprIsCheap e
 exprIsCheap (Lam x e)       	= if isId x then True else exprIsCheap e
-exprIsCheap (Let bind body) 	= all exprIsCheap (rhssOfBind bind) && exprIsCheap body
-exprIsCheap (Case scrut _ alts) = exprIsCheap scrut && 
-				  all (\(_,_,rhs) -> exprIsCheap rhs) alts
+
+--	I'm not at all convinced about these two!!
+--	[SLPJ June 99]
+-- exprIsCheap (Let bind body) 	= all exprIsCheap (rhssOfBind bind) && exprIsCheap body
+-- exprIsCheap (Case scrut _ alts) = exprIsCheap scrut && 
+--		  		     all (\(_,_,rhs) -> exprIsCheap rhs) alts
 
 exprIsCheap other_expr   -- look for manifest partial application
   = case collectArgs other_expr of
@@ -326,14 +275,19 @@ exprIsBottom e = go 0 e
 		 go n (Lam _ _)	   = False
 \end{code}
 
-@exprIsValue@ returns true for expressions that are evaluated.
-It does not treat variables as evaluated.
+@exprIsValue@ returns true for expressions that are certainly *already* 
+evaluated to WHNF.  This is used to decide wether it's ok to change
+	case x of _ -> e   ===>   e
+
+and to decide whether it's safe to discard a `seq`
+
+So, it does *not* treat variables as evaluated, unless they say they are
 
 \begin{code}
 exprIsValue :: CoreExpr -> Bool		-- True => Value-lambda, constructor, PAP
 exprIsValue (Type ty)	  = True	-- Types are honorary Values; we don't mind
 					-- copying them
-exprIsValue (Var v)    	  = False
+exprIsValue (Var v)    	  = isEvaldUnfolding (getIdUnfolding v)
 exprIsValue (Lam b e)  	  = isId b || exprIsValue e
 exprIsValue (Note _ e) 	  = exprIsValue e
 exprIsValue (Let _ e)     = False
@@ -346,39 +300,6 @@ exprIsValue e@(App _ _)   = case collectArgs e of
 				  _	        -> False
 \end{code}
 
-exprIsWHNF reports True for head normal forms.  Note that does not necessarily
-mean *normal* forms; constructors might have non-trivial argument expressions, for
-example.  We use a let binding for WHNFs, rather than a case binding, even if it's
-used strictly.  We try to expose WHNFs by floating lets out of the RHS of lets.
-
-	We treat applications of buildId and augmentId as honorary WHNFs, 
-	because we want them to get exposed.
-	[May 99: I've disabled this because it looks jolly dangerous:
-	 we'll substitute inside lambda with potential big loss of sharing.]
-
-\begin{code}
-exprIsWHNF :: CoreExpr -> Bool	-- True => Variable, value-lambda, constructor, PAP
-exprIsWHNF (Type ty)	      = True	-- Types are honorary WHNFs; we don't mind
-					-- copying them
-exprIsWHNF (Var v)    	      = True
-exprIsWHNF (Lam b e)  	      = isId b || exprIsWHNF e
-exprIsWHNF (Note _ e) 	      = exprIsWHNF e
-exprIsWHNF (Let _ e)          = False
-exprIsWHNF (Case _ _ _)       = False
-exprIsWHNF (Con con _)        = isWHNFCon con 
-exprIsWHNF e@(App _ _)        = case collectArgs e of  
-				  (Var v, args) -> n_val_args == 0
-						|| fun_arity > n_val_args
---  [May 99: disabled. See note above]		|| v_uniq == buildIdKey
---						|| v_uniq == augmentIdKey
-						where
-						   n_val_args = valArgCount args
-						   fun_arity  = arityLowerBound (getIdArity v)
-						   v_uniq     = idUnique v
-
-				  _	        -> False
-\end{code}
-
 \begin{code}
 exprArity :: CoreExpr -> Int	-- How many value lambdas are at the top
 exprArity (Lam b e) | isTyVar b = exprArity e
@@ -411,6 +332,14 @@ cheapEqExpr (App f1 a1) (App f2 a2)
 cheapEqExpr (Type t1) (Type t2) = t1 == t2
 
 cheapEqExpr _ _ = False
+
+exprIsBig :: Expr b -> Bool
+-- Returns True of expressions that are too big to be compared by cheapEqExpr
+exprIsBig (Var v)      = False
+exprIsBig (Type t)     = False
+exprIsBig (App f a)    = exprIsBig f || exprIsBig a
+exprIsBig (Con _ args) = any exprIsBig args
+exprIsBig other	       = True
 \end{code}
 
 
@@ -463,3 +392,28 @@ eqExpr e1 e2
     eq_note env other1	       other2	      = False
 \end{code}
 
+%************************************************************************
+%*									*
+\subsection{Hashing}
+%*									*
+%************************************************************************
+
+\begin{code}
+hashExpr :: CoreExpr -> Int
+hashExpr (Note _ e)   		 = hashExpr e
+hashExpr (Let (NonRec b r) e)    = hashId b
+hashExpr (Let (Rec ((b,r):_)) e) = hashId b
+hashExpr (Case _ b _)		 = hashId b
+hashExpr (App f e)   		 = hashExpr f
+hashExpr (Var v)     		 = hashId v
+hashExpr (Con con args)   	 = hashArgs args (hashCon con)
+hashExpr (Lam b _)	         = hashId b
+hashExpr (Type t)	         = trace "hashExpr: type" 0		-- Shouldn't happen
+
+hashArgs []		 con = con
+hashArgs (Type t : args) con = hashArgs args con
+hashArgs (arg    : args) con = hashExpr arg
+
+hashId :: Id -> Int
+hashId id = hashName (idName id)
+\end{code}
diff --git a/ghc/compiler/coreSyn/PprCore.lhs b/ghc/compiler/coreSyn/PprCore.lhs
index 397bea460039ce22a0a08eafa5496c1e86e61c0e..3f3b5a073c268cc7b4c993a19295109a72987450 100644
--- a/ghc/compiler/coreSyn/PprCore.lhs
+++ b/ghc/compiler/coreSyn/PprCore.lhs
@@ -24,7 +24,7 @@ import IdInfo		( IdInfo,
 			  arityInfo, ppArityInfo, ppFlavourInfo, flavourInfo,
 			  demandInfo, updateInfo, ppUpdateInfo, specInfo, 
 			  strictnessInfo, ppStrictnessInfo, cafInfo, ppCafInfo,
-			  cprInfo, ppCprInfo
+			  cprInfo, ppCprInfo, lbvarInfo
 			)
 import Const		( Con(..), DataCon )
 import DataCon		( isTupleCon, isUnboxedTupleCon )
@@ -332,8 +332,8 @@ pprTypedBinder binder
 	-- It's important that the type is parenthesised too, at least when
 	-- printing interfaces, because we get \ x::(a->b) y::(c->d) -> ...
 
--- When printing any Id binder in debug mode, we print its inline pragma
-pprIdBndr id = ppr id <+> ifPprDebug (ppr (getInlinePragma id) <+> ppr (getIdDemandInfo id)) 
+-- When printing any Id binder in debug mode, we print its inline pragma and one-shot-ness
+pprIdBndr id = ppr id <+> ifPprDebug (ppr (getInlinePragma id) <+> ppr (getIdDemandInfo id)) <+> ppr (lbvarInfo (idInfo id))
 \end{code}
 
 
@@ -348,6 +348,7 @@ ppIdInfo info
 	    ppr d,
 	    ppCafInfo c,
             ppCprInfo m,
+	    ppr (lbvarInfo info),
 	    pprIfaceCoreRules p
 	-- Inline pragma printed out with all binders; see PprCore.pprIdBndr
 	]
diff --git a/ghc/compiler/coreSyn/Subst.lhs b/ghc/compiler/coreSyn/Subst.lhs
index e2c25848f6b3d2862462afc349d49d00e2bda9a4..b3f93eac2118028bd03f07e6401891ce0d04e850 100644
--- a/ghc/compiler/coreSyn/Subst.lhs
+++ b/ghc/compiler/coreSyn/Subst.lhs
@@ -35,7 +35,6 @@ module Subst (
 import CoreSyn		( Expr(..), Bind(..), Note(..), CoreExpr, CoreBndr,
 			  CoreRules(..), CoreRule(..), emptyCoreRules, isEmptyCoreRules
 			)
-import CoreUnfold	( hasUnfolding, noUnfolding )
 import CoreFVs		( exprFreeVars )
 import Type		( Type(..), ThetaType, TyNote(..), 
 			  tyVarsOfType, tyVarsOfTypes, mkAppTy
diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs
index 2f75b20356b8b84c1ab89c759c59af4083424a78..ffe9d6ba749845d9c2503a1004988e5e1d0608ed 100644
--- a/ghc/compiler/main/CmdLineOpts.lhs
+++ b/ghc/compiler/main/CmdLineOpts.lhs
@@ -20,6 +20,7 @@ module CmdLineOpts (
 	opt_D_dump_absC,
 	opt_D_dump_asm,
 	opt_D_dump_cpranal,
+	opt_D_dump_cse,
 	opt_D_dump_deriv,
 	opt_D_dump_ds,
 	opt_D_dump_flatC,
@@ -215,6 +216,7 @@ data CoreToDo		-- These are diff core-to-core passes,
   | CoreDoSpecialising
   | CoreDoUSPInf
   | CoreDoCPResult 
+  | CoreCSE
 \end{code}
 
 \begin{code}
@@ -314,6 +316,7 @@ opt_D_dump_stranal		= lookUp  SLIT("-ddump-stranal")
 opt_D_dump_tc			= lookUp  SLIT("-ddump-tc")
 opt_D_dump_rules		= lookUp  SLIT("-ddump-rules")
 opt_D_dump_usagesp              = lookUp  SLIT("-ddump-usagesp")
+opt_D_dump_cse 	                = lookUp  SLIT("-ddump-cse")
 opt_D_dump_worker_wrapper	= lookUp  SLIT("-ddump-workwrap")
 opt_D_show_passes		= lookUp  SLIT("-dshow-passes")
 opt_D_dump_rn_trace		= lookUp  SLIT("-ddump-rn-trace")
@@ -420,8 +423,8 @@ opt_UF_FunAppDiscount		= lookup_def_int "-funfolding-fun-discount"	   (6::Int)	-
 opt_UF_PrimArgDiscount		= lookup_def_int "-funfolding-prim-discount"	   (1::Int)
 opt_UF_KeenessFactor		= lookup_def_float "-funfolding-keeness-factor"	   (2.0::Float)
 
-opt_UF_CheapOp  = ( 1 :: Int)
-opt_UF_DearOp   = ( 8 :: Int)
+opt_UF_CheapOp  = ( 0 :: Int)	-- Only one instruction; and the args are charged for
+opt_UF_DearOp   = ( 4 :: Int)
 opt_UF_NoRepLit = ( 20 :: Int)	-- Strings can be pretty big
 			
 opt_ProduceS  			= lookup_str "-S="
@@ -468,6 +471,7 @@ classifyOpts = sep argv [] [] -- accumulators...
 	  "-ffloat-inwards"  -> CORE_TD(CoreDoFloatInwards)
 	  "-ffull-laziness"  -> CORE_TD(CoreDoFullLaziness)
 	  "-fliberate-case"  -> CORE_TD(CoreLiberateCase)
+	  "-fcse"  	     -> CORE_TD(CoreCSE)
 	  "-fprint-core"     -> CORE_TD(CoreDoPrintCore)
 	  "-fstatic-args"    -> CORE_TD(CoreDoStaticArgs)
 	  "-fstrictness"     -> CORE_TD(CoreDoStrictness)
diff --git a/ghc/compiler/prelude/PrelInfo.lhs b/ghc/compiler/prelude/PrelInfo.lhs
index 511dc85a9e1c31c1b36707871153934fe86a97e8..c84d072c025287fe7ada2e726a3491f80e975cbe 100644
--- a/ghc/compiler/prelude/PrelInfo.lhs
+++ b/ghc/compiler/prelude/PrelInfo.lhs
@@ -75,7 +75,7 @@ import Var		( varUnique, Id )
 import Name		( Name, OccName, Provenance(..), 
 			  NameSpace, tcName, clsName, varName, dataName,
 			  mkKnownKeyGlobal,
-			  getName, mkGlobalName, nameRdrName, systemProvenance
+			  getName, mkGlobalName, nameRdrName
 			)
 import RdrName		( rdrNameModule, rdrNameOcc, mkSrcQual )
 import Class		( Class, classKey )
diff --git a/ghc/compiler/prelude/PrimOp.lhs b/ghc/compiler/prelude/PrimOp.lhs
index 41793af100e76d83fa05be285579341da7a7be8a..6634fe89cdcc3bb400789b6b51896bc92dbda34f 100644
--- a/ghc/compiler/prelude/PrimOp.lhs
+++ b/ghc/compiler/prelude/PrimOp.lhs
@@ -7,7 +7,7 @@
 module PrimOp (
 	PrimOp(..), allThePrimOps,
 	primOpType, primOpSig, primOpUsg,
-	mkPrimOpIdName, primOpRdrName,
+	mkPrimOpIdName, primOpRdrName, primOpTag,
 
 	commutableOp,
 
@@ -304,6 +304,9 @@ about using it this way?? ADR)
 Used for the Ord instance
 
 \begin{code}
+primOpTag :: PrimOp -> Int
+primOpTag op = IBOX( tagOf_PrimOp op )
+
 tagOf_PrimOp CharGtOp			      = (ILIT( 1) :: FAST_INT)
 tagOf_PrimOp CharGeOp			      = ILIT(  2)
 tagOf_PrimOp CharEqOp			      = ILIT(  3)
@@ -2138,7 +2141,7 @@ mkPrimOpIdName op id
   = mkWiredInIdName key pREL_GHC occ_name id
   where
     occ_name = primOpOcc op
-    key	     = mkPrimOpIdUnique (IBOX(tagOf_PrimOp op))
+    key	     = mkPrimOpIdUnique (primOpTag op)
 
 
 primOpRdrName :: PrimOp -> RdrName 
diff --git a/ghc/compiler/simplCore/ConFold.lhs b/ghc/compiler/simplCore/ConFold.lhs
index 9299be2dca4ee903e6e4c4b54101cac5eba49d2b..a96758f04a14e7a3a162dee2d5bbb020239138de 100644
--- a/ghc/compiler/simplCore/ConFold.lhs
+++ b/ghc/compiler/simplCore/ConFold.lhs
@@ -18,13 +18,14 @@ import Const		( mkMachInt, mkMachWord, Literal(..), Con(..) )
 import PrimOp		( PrimOp(..) )
 import SimplMonad
 import TysWiredIn	( trueDataCon, falseDataCon )
-import TyCon		( tyConDataCons, isEnumerationTyCon )
-import DataCon		( dataConTag, fIRST_TAG )
+import TyCon		( tyConDataCons, isEnumerationTyCon, isNewTyCon )
+import DataCon		( dataConTag, dataConTyCon, fIRST_TAG )
 import Const		( conOkForAlt )
-import CoreUnfold	( Unfolding(..), isEvaldUnfolding )
+import CoreUnfold	( maybeUnfoldingTemplate )
 import CoreUtils	( exprIsValue )
 import Type		( splitTyConApp_maybe )
 
+import Maybes		( maybeToBool )
 import Char		( ord, chr )
 import Outputable
 \end{code}
@@ -92,11 +93,8 @@ The second case must never be floated outside of the first!
 
 \begin{code}
 tryPrimOp SeqOp [Type ty, arg]
-  | is_evald arg
+  | exprIsValue arg
   = Just (Con (Literal (mkMachInt 1)) [])
-  where
-    is_evald (Var v) = isEvaldUnfolding (getIdUnfolding v)
-    is_evald arg     = exprIsValue arg
 \end{code}
 
 \begin{code}
@@ -118,18 +116,14 @@ For dataToTag#, we can reduce if either
 tryPrimOp DataToTagOp [Type ty, Con (DataCon dc) _]
   = Just (Con (Literal (mkMachInt (toInteger (dataConTag dc - fIRST_TAG)))) [])
 tryPrimOp DataToTagOp [Type ty, Var x]
-  | has_unfolding && unfolding_is_constr
-  = Just (Con (Literal (mkMachInt (toInteger (dataConTag dc - fIRST_TAG)))) [])
+  | maybeToBool maybe_constr
+  = ASSERT( not (isNewTyCon (dataConTyCon dc)) )
+    Just (Con (Literal (mkMachInt (toInteger (dataConTag dc - fIRST_TAG)))) [])
   where
-    has_unfolding = case unfolding of
-			CoreUnfolding _ _ _ -> True
-			other		    -> False
-    unfolding = getIdUnfolding x
-    CoreUnfolding form guidance unf_template = unfolding
-    unfolding_is_constr = case unf_template of
-				  Con con@(DataCon _) _ -> conOkForAlt con
-				  other	    -> False
-    Con (DataCon dc) con_args = unf_template
+    maybe_constr = case maybeUnfoldingTemplate (getIdUnfolding x) of
+			Just (Con (DataCon dc) _) -> Just dc
+			other			  -> Nothing
+    Just dc = maybe_constr
 \end{code}
 
 \begin{code}
diff --git a/ghc/compiler/simplCore/FloatIn.lhs b/ghc/compiler/simplCore/FloatIn.lhs
index 6fc36c8de249f3006149c890fff605980a27dd31..97e1c06aad8babe3702ccc2cd298615ba4fcf290 100644
--- a/ghc/compiler/simplCore/FloatIn.lhs
+++ b/ghc/compiler/simplCore/FloatIn.lhs
@@ -342,7 +342,15 @@ fiExpr to_drop (_, AnnCase scrut case_bndr alts)
     fi_alt to_drop (con, args, rhs) = (con, args, fiExpr to_drop rhs)
 
 noFloatIntoRhs (AnnNote InlineMe _) = True
-noFloatIntoRhs (AnnLam _ _)   	    = True
+noFloatIntoRhs (AnnLam b _)   	    = not (isId b && isOneShotLambda b)
+	-- IMPORTANT: don't say 'True' for a RHS with a one-shot lambda at the top.
+	-- This makes a big difference for things like
+	--	f x# = let x = I# x#
+	--	       in let j = \() -> ...x...
+	--		  in if <condition> then normal-path else j ()
+	-- If x is used only in the error case join point, j, we must float the
+	-- boxing constructor into it, else we box it every time which is very bad
+	-- news indeed.
 noFloatIntoRhs (AnnCon con _)       = isDataCon con
 noFloatIntoRhs other	            = False
 \end{code}
diff --git a/ghc/compiler/simplCore/SetLevels.lhs b/ghc/compiler/simplCore/SetLevels.lhs
index 2acdc9dcaad277db278373dc573b92ae662d0a59..c41fecb83871ca22df2b73b5f3d3518ed4325ef7 100644
--- a/ghc/compiler/simplCore/SetLevels.lhs
+++ b/ghc/compiler/simplCore/SetLevels.lhs
@@ -16,6 +16,8 @@
 * We clone the binders of any floatable let-binding, so that when it is
   floated out it will be unique.  (This used to be done by the simplifier
   but the latter now only ensures that there's no shadowing.)
+  NOTE: Very tiresomely, we must apply this substitution to
+	the rules stored inside a variable too.
 
 
 
@@ -34,9 +36,11 @@ import CoreSyn
 
 import CoreUtils	( coreExprType, exprIsTrivial, exprIsBottom )
 import CoreFVs		-- all of it
-import Id		( Id, idType, mkSysLocal, isOneShotLambda )
+import Id		( Id, idType, mkSysLocal, isOneShotLambda, modifyIdInfo )
+import IdInfo		( specInfo, setSpecInfo )
 import Var		( IdOrTyVar, Var, setVarUnique )
 import VarEnv
+import Subst
 import VarSet
 import Type		( isUnLiftedType, mkTyVarTys, mkForAllTys, Type )
 import VarSet
@@ -144,36 +148,6 @@ instance Outputable Level where
   ppr (Level maj min) = hcat [ char '<', int maj, char ',', int min, char '>' ]
 \end{code}
 
-\begin{code}
-type LevelEnv = VarEnv (Var, Level)
-	-- We clone let-bound variables so that they are still
-	-- distinct when floated out; hence the Var in the range
-
-extendLvlEnv :: LevelEnv -> [(Var,Level)] -> LevelEnv
-	-- Used when *not* cloning
-extendLvlEnv env prs = foldl add env prs
-		     where
-			add env (v,l) = extendVarEnv env v (v,l)
-
-varLevel :: LevelEnv -> IdOrTyVar -> Level
-varLevel env v
-  = case lookupVarEnv env v of
-      Just (_,level) -> level
-      Nothing        -> tOP_LEVEL
-
-maxIdLvl :: LevelEnv -> IdOrTyVar -> Level -> Level
-maxIdLvl env var lvl | isTyVar var = lvl
-		     | otherwise   = case lookupVarEnv env var of
-					Just (_,lvl') -> maxLvl lvl' lvl
-					Nothing       -> lvl 
-
-maxTyVarLvl :: LevelEnv -> IdOrTyVar -> Level -> Level
-maxTyVarLvl env var lvl | isId var  = lvl
-		        | otherwise = case lookupVarEnv env var of
-					Just (_,lvl') -> maxLvl lvl' lvl
-					Nothing       -> lvl 
-\end{code}
-
 %************************************************************************
 %*									*
 \subsection{Main level-setting code}
@@ -199,8 +173,6 @@ setLevels binds us
 	do_them bs	`thenLvl` \ lvld_binds ->
     	returnLvl (lvld_bind ++ lvld_binds)
 
-initialEnv = emptyVarEnv
-
 lvlTopBind (NonRec binder rhs)
   = lvlBind Top initialEnv (AnnNonRec binder (freeVars rhs))
 					-- Rhs can have no free vars!
@@ -225,10 +197,7 @@ lvlBind :: Level
 
 lvlBind ctxt_lvl env (AnnNonRec bndr rhs)
   = setFloatLevel (Just bndr) ctxt_lvl env rhs ty 	`thenLvl` \ (final_lvl, rhs') ->
-    cloneVar ctxt_lvl bndr				`thenLvl` \ new_bndr ->
-    let
-	new_env = extendVarEnv env bndr (new_bndr,final_lvl)
-    in
+    cloneVar ctxt_lvl env bndr final_lvl		`thenLvl` \ (new_env, new_bndr) ->
     returnLvl ([NonRec (new_bndr, final_lvl) rhs'], new_env)
   where
     ty = idType bndr
@@ -269,9 +238,7 @@ If there were another lambda in @r@'s rhs, it would get level-2 as well.
 
 \begin{code}
 lvlExpr _ _ (_, AnnType ty) = returnLvl (Type ty)
-lvlExpr _ env (_, AnnVar v) = case lookupVarEnv env v of
-				Just (v',_) -> returnLvl (Var v')
-				Nothing     -> returnLvl (Var v)
+lvlExpr _ env (_, AnnVar v) = returnLvl (lookupVar env v)
 
 lvlExpr ctxt_lvl env (_, AnnCon con args)
   = mapLvl (lvlExpr ctxt_lvl env) args	`thenLvl` \ args' ->
@@ -297,16 +264,17 @@ lvlExpr ctxt_lvl env (_, AnnLam bndr rhs)
   = lvlMFE incd_lvl new_env body	`thenLvl` \ body' ->
     returnLvl (mkLams lvld_bndrs body')
   where
-    bndr_is_id    = isId bndr
-    bndr_is_tyvar = isTyVar bndr
-    (bndrs, body) = go rhs
+    bndr_is_id         = isId bndr
+    bndr_is_tyvar      = isTyVar bndr
+    (more_bndrs, body) = go rhs
+    bndrs 	       = bndr : more_bndrs
 
     incd_lvl   | bndr_is_id && not (all isOneShotLambda bndrs) = incMajorLvl ctxt_lvl
 	       | otherwise				       = incMinorLvl ctxt_lvl
 	-- Only bump the major level number if the binders include
 	-- at least one more-than-one-shot lambda
 
-    lvld_bndrs = [(b,incd_lvl) | b <- (bndr:bndrs)]
+    lvld_bndrs = [(b,incd_lvl) | b <- bndrs]
     new_env    = extendLvlEnv env lvld_bndrs
 
     go (_, AnnLam bndr rhs) |  bndr_is_id && isId bndr 
@@ -326,7 +294,7 @@ lvlExpr ctxt_lvl env (_, AnnCase expr case_bndr alts)
   where
       expr_type = coreExprType (deAnnotate expr)
       incd_lvl  = incMinorLvl ctxt_lvl
-      alts_env  = extendVarEnv env case_bndr (case_bndr,incd_lvl)
+      alts_env  = extendLvlEnv env [(case_bndr,incd_lvl)]
 
       lvl_alt (con, bs, rhs)
         = let
@@ -563,7 +531,7 @@ lvlRecBind ctxt_lvl env pairs
     in
     mapLvl (lvlExpr incd_lvl rhs_env) rhss	`thenLvl` \ rhss' ->
     mapLvl newLvlVar poly_tys			`thenLvl` \ poly_vars ->
-    mapLvl (cloneVar ctxt_lvl) bndrs		`thenLvl` \ new_bndrs ->
+    cloneVars ctxt_lvl env bndrs ctxt_lvl	`thenLvl` \ (new_env, new_bndrs) ->
     let
 		-- The "d_rhss" are the right-hand sides of "D" and "D'"
 		-- in the documentation above
@@ -582,7 +550,6 @@ lvlRecBind ctxt_lvl env pairs
 		-- The new right-hand sides, just a type application,
 		-- aren't worth floating so pin it with ctxt_lvl
 	bndrs_w_lvl = new_bndrs `zip` repeat ctxt_lvl
-	new_env	    = extendVarEnvList env (bndrs `zip` bndrs_w_lvl)
 
 		-- "d_binds" are the "D" in the documentation above
 	d_binds	= zipWithEqual "SetLevels" NonRec bndrs_w_lvl d_rhss
@@ -591,10 +558,9 @@ lvlRecBind ctxt_lvl env pairs
 
   | otherwise
   =	-- Let it float freely
-    mapLvl (cloneVar ctxt_lvl) bndrs			`thenLvl` \ new_bndrs ->
+    cloneVars ctxt_lvl env bndrs expr_lvl		`thenLvl` \ (new_env, new_bndrs) ->
     let
 	bndrs_w_lvls = new_bndrs `zip` repeat expr_lvl
-	new_env      = extendVarEnvList env (bndrs `zip` bndrs_w_lvls)
     in
     mapLvl (lvlExpr expr_lvl new_env) rhss	`thenLvl` \ rhss' ->
     returnLvl ([Rec (bndrs_w_lvls `zip` rhss')], new_env)
@@ -626,6 +592,46 @@ lvlRecBind ctxt_lvl env pairs
 %*									*
 %************************************************************************
 
+\begin{code}
+type LevelEnv = (VarEnv Level, SubstEnv)
+	-- We clone let-bound variables so that they are still
+	-- distinct when floated out; hence the SubstEnv
+	-- The domain of the VarEnv is *pre-cloned* Ids, though
+
+initialEnv :: LevelEnv
+initialEnv = (emptyVarEnv, emptySubstEnv)
+
+extendLvlEnv :: LevelEnv -> [(Var,Level)] -> LevelEnv
+	-- Used when *not* cloning
+extendLvlEnv (lvl_env, subst_env) prs
+   = (foldl add lvl_env prs, subst_env)
+   where
+     add env (v,l) = extendVarEnv env v l
+
+varLevel :: LevelEnv -> IdOrTyVar -> Level
+varLevel (lvl_env, _) v
+  = case lookupVarEnv lvl_env v of
+      Just level -> level
+      Nothing    -> tOP_LEVEL
+
+lookupVar :: LevelEnv -> Id -> LevelledExpr
+lookupVar (_, subst) v = case lookupSubstEnv subst v of
+			   Just (DoneEx (Var v')) -> Var v'	-- Urgh!  Types don't match
+			   other	          -> Var v
+
+maxIdLvl :: LevelEnv -> IdOrTyVar -> Level -> Level
+maxIdLvl (lvl_env,_) var lvl | isTyVar var = lvl
+		             | otherwise   = case lookupVarEnv lvl_env var of
+						Just lvl' -> maxLvl lvl' lvl
+						Nothing   -> lvl 
+
+maxTyVarLvl :: LevelEnv -> IdOrTyVar -> Level -> Level
+maxTyVarLvl (lvl_env,_) var lvl | isId var  = lvl
+		                | otherwise = case lookupVarEnv lvl_env var of
+						Just lvl' -> maxLvl lvl' lvl
+						Nothing   -> lvl 
+\end{code}
+
 \begin{code}
 type LvlM result = UniqSM result
 
@@ -640,8 +646,40 @@ newLvlVar :: Type -> LvlM Id
 newLvlVar ty = getUniqueUs	`thenLvl` \ uniq ->
 	       returnUs (mkSysLocal SLIT("lvl") uniq ty)
 
-cloneVar :: Level -> Id -> LvlM Id
-cloneVar Top v = returnUs v	-- Don't clone top level things
-cloneVar _ v   = getUniqueUs	`thenLvl` \ uniq ->
-	         returnUs (setVarUnique v uniq)
+-- The deeply tiresome thing is that we have to apply the substitution
+-- to the rules inside each Id.  Grr.  But it matters.
+
+cloneVar :: Level -> LevelEnv -> Id -> Level -> LvlM (LevelEnv, Id)
+cloneVar Top env v lvl
+  = returnUs (env, v)	-- Don't clone top level things
+cloneVar _   (lvl_env, subst_env) v lvl
+  = getUniqueUs	`thenLvl` \ uniq ->
+    let
+      subst	 = mkSubst emptyVarSet subst_env
+      v'	 = setVarUnique v uniq
+      v''	 = apply_to_rules subst v'
+      subst_env' = extendSubstEnv subst_env v (DoneEx (Var v''))
+      lvl_env'   = extendVarEnv lvl_env v lvl
+    in
+    returnUs ((lvl_env', subst_env'), v'')
+
+cloneVars :: Level -> LevelEnv -> [Id] -> Level -> LvlM (LevelEnv, [Id])
+cloneVars Top env vs lvl 
+  = returnUs (env, vs)	-- Don't clone top level things
+cloneVars _   (lvl_env, subst_env) vs lvl
+  = getUniquesUs (length vs)	`thenLvl` \ uniqs ->
+    let
+      subst	 = mkSubst emptyVarSet subst_env'
+      vs'	 = zipWith setVarUnique vs uniqs
+      vs''	 = map (apply_to_rules subst) vs'
+      subst_env' = extendSubstEnvList subst_env vs [DoneEx (Var v'') | v'' <- vs'']
+      lvl_env'   = extendVarEnvList lvl_env (vs `zip` repeat lvl)
+    in
+    returnUs ((lvl_env', subst_env'), vs'')
+
+-- Apply the substitution to the rules
+apply_to_rules subst id
+  = modifyIdInfo go_spec id
+  where
+    go_spec info = info `setSpecInfo` substRules subst (specInfo info)
 \end{code}
diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs
index 7e17ed1266d573b3954a24f235b7a828ce3db439..995d02674d6453f40d3f89a9424b7183bbf1b9c2 100644
--- a/ghc/compiler/simplCore/SimplCore.lhs
+++ b/ghc/compiler/simplCore/SimplCore.lhs
@@ -1,561 +1,563 @@
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-%
-\section[SimplCore]{Driver for simplifying @Core@ programs}
-
-\begin{code}
-module SimplCore ( core2core ) where
-
-#include "HsVersions.h"
-
-import CmdLineOpts	( CoreToDo(..), SimplifierSwitch(..), 
-			  SwitchResult(..), switchIsOn, intSwitchSet,
-			  opt_D_dump_occur_anal, opt_D_dump_rules,
-			  opt_D_dump_simpl_iterations,
-			  opt_D_dump_simpl_stats,
-			  opt_D_dump_simpl, opt_D_dump_rules,
-			  opt_D_verbose_core2core,
-			  opt_D_dump_occur_anal,
-                          opt_UsageSPOn,
-			)
-import CoreLint		( beginPass, endPass )
-import CoreTidy		( tidyCorePgm )
-import CoreSyn
-import Rules		( RuleBase, ProtoCoreRule(..), pprProtoCoreRule, prepareRuleBase, orphanRule )
-import CoreUnfold
-import PprCore		( pprCoreBindings )
-import OccurAnal	( occurAnalyseBinds )
-import CoreUtils	( exprIsTrivial, coreExprType )
-import Simplify		( simplTopBinds, simplExpr )
-import SimplUtils	( etaCoreExpr, findDefault, simplBinders )
-import SimplMonad
-import Const		( Con(..), Literal(..), literalType, mkMachInt )
-import ErrUtils		( dumpIfSet )
-import FloatIn		( floatInwards )
-import FloatOut		( floatOutwards )
-import Id		( Id, mkSysLocal, mkVanillaId, isBottomingId,
-			  idType, setIdType, idName, idInfo, setIdNoDiscard
-			)
-import VarEnv
-import VarSet
-import Module		( Module )
-import Name		( mkLocalName, tidyOccName, tidyTopName, 
-			  NamedThing(..), OccName
-			)
-import TyCon		( TyCon, isDataTyCon )
-import PrimOp		( PrimOp(..) )
-import PrelInfo		( unpackCStringId, unpackCString2Id, addr2IntegerId )
-import Type		( Type, splitAlgTyConApp_maybe, 
-			  isUnLiftedType,
-			  tidyType, tidyTypes, tidyTopType, tidyTyVar, tidyTyVars,
-			  Type
-			)
-import TysWiredIn	( smallIntegerDataCon, isIntegerTy )
-import LiberateCase	( liberateCase )
-import SAT		( doStaticArgs )
-import Specialise	( specProgram)
-import UsageSPInf       ( doUsageSPInf )
-import StrictAnal	( saBinds )
-import WorkWrap	        ( wwTopBinds )
-import CprAnalyse       ( cprAnalyse )
-
-import Unique		( Unique, Uniquable(..),
-			  ratioTyConKey
-		        )
-import UniqSupply	( UniqSupply, mkSplitUniqSupply, splitUniqSupply, uniqFromSupply )
-import Constants	( tARGET_MIN_INT, tARGET_MAX_INT )
-import Util		( mapAccumL )
-import SrcLoc		( noSrcLoc )
-import Bag
-import Maybes
-import IO		( hPutStr, stderr )
-import Outputable
-
-import Ratio 		( numerator, denominator )
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection{The driver for the simplifier}
-%*									*
-%************************************************************************
-
-\begin{code}
-core2core :: [CoreToDo]		-- Spec of what core-to-core passes to do
-	  -> [CoreBind]		-- Binds in
-	  -> [ProtoCoreRule]	-- Rules
-	  -> IO ([CoreBind], [ProtoCoreRule])
-
-core2core core_todos binds rules
-  = do
-	us <-  mkSplitUniqSupply 's'
-	let (cp_us, us1)   = splitUniqSupply us
-	    (ru_us, ps_us) = splitUniqSupply us1
-
-        better_rules <- simplRules ru_us rules binds
-
-	let (binds1, rule_base) = prepareRuleBase binds better_rules
-
-	-- Do the main business
-	(stats, processed_binds) <- doCorePasses zeroSimplCount cp_us binds1 
-						 rule_base core_todos
-
-	dumpIfSet opt_D_dump_simpl_stats
-		  "Grand total simplifier statistics"
-		  (pprSimplCount stats)
-
-	-- Do the post-simplification business
-	post_simpl_binds <- doPostSimplification ps_us processed_binds
-
-	-- Return results
-	return (post_simpl_binds, filter orphanRule better_rules)
-   
-
-doCorePasses stats us binds irs []
-  = return (stats, binds)
-
-doCorePasses stats us binds irs (to_do : to_dos) 
-  = do
-	let (us1, us2) =  splitUniqSupply us
-	(stats1, binds1) <- doCorePass us1 binds irs to_do
-	doCorePasses (stats `plusSimplCount` stats1) us2 binds1 irs to_dos
-
-doCorePass us binds rb (CoreDoSimplify sw_chkr) = _scc_ "Simplify"      simplifyPgm rb sw_chkr us binds
-doCorePass us binds rb CoreLiberateCase	        = _scc_ "LiberateCase"  noStats (liberateCase binds)
-doCorePass us binds rb CoreDoFloatInwards       = _scc_ "FloatInwards"  noStats (floatInwards binds)
-doCorePass us binds rb CoreDoFullLaziness       = _scc_ "FloatOutwards" noStats (floatOutwards us binds)
-doCorePass us binds rb CoreDoStaticArgs	        = _scc_ "StaticArgs"    noStats (doStaticArgs us binds)
-doCorePass us binds rb CoreDoStrictness	        = _scc_ "Stranal"       noStats (saBinds binds)
-doCorePass us binds rb CoreDoWorkerWrapper      = _scc_ "WorkWrap"      noStats (wwTopBinds us binds)
-doCorePass us binds rb CoreDoSpecialising       = _scc_ "Specialise"    noStats (specProgram us binds)
-doCorePass us binds rb CoreDoCPResult	        = _scc_ "CPResult"      noStats (cprAnalyse binds)
-doCorePass us binds rb CoreDoPrintCore	        = _scc_ "PrintCore"     noStats (printCore binds)
-doCorePass us binds rb CoreDoUSPInf
-  = _scc_ "CoreUsageSPInf" 
-    if opt_UsageSPOn then
-      noStats (doUsageSPInf us binds)
-    else
-      trace "WARNING: ignoring requested -fusagesp pass; requires -fusagesp-on" $
-      noStats (return binds)
-
-printCore binds = do dumpIfSet True "Print Core"
-			       (pprCoreBindings binds)
-		     return binds
-
-noStats thing = do { result <- thing; return (zeroSimplCount, result) }
-\end{code}
-
-
-%************************************************************************
-%*									*
-\subsection{Dealing with rules}
-%*									*
-%************************************************************************
-
-We must do some gentle simplifiation on the template (but not the RHS)
-of each rule.  The case that forced me to add this was the fold/build rule,
-which without simplification looked like:
-	fold k z (build (/\a. g a))  ==>  ...
-This doesn't match unless you do eta reduction on the build argument.
-
-\begin{code}
-simplRules :: UniqSupply -> [ProtoCoreRule] -> [CoreBind] -> IO [ProtoCoreRule]
-simplRules us rules binds
-  = do  let (better_rules,_) = initSmpl sw_chkr us bind_vars black_list_all (mapSmpl simplRule rules)
-	
-	dumpIfSet opt_D_dump_rules
-		  "Transformation rules"
-		  (vcat (map pprProtoCoreRule better_rules))
-
-	return better_rules
-  where
-    black_list_all v = True 		-- This stops all inlining
-    sw_chkr any = SwBool False		-- A bit bogus
-
-	-- Boringly, we need to gather the in-scope set.
-	-- Typically this thunk won't even be force, but the test in
-	-- simpVar fails if it isn't right, and it might conceivably matter
-    bind_vars = foldr (unionVarSet . mkVarSet . bindersOf) emptyVarSet binds
-
-
-simplRule rule@(ProtoCoreRule is_local id (Rule name bndrs args rhs))
-  | not is_local
-  = returnSmpl rule	-- No need to fiddle with imported rules
-  | otherwise
-  = simplBinders bndrs			$ \ bndrs' -> 
-    mapSmpl simplExpr args		`thenSmpl` \ args' ->
-    simplExpr rhs			`thenSmpl` \ rhs' ->
-    returnSmpl (ProtoCoreRule is_local id (Rule name bndrs' args' rhs'))
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection{The driver for the simplifier}
-%*									*
-%************************************************************************
-
-\begin{code}
-simplifyPgm :: RuleBase
-	    -> (SimplifierSwitch -> SwitchResult)
-	    -> UniqSupply
-	    -> [CoreBind]				-- Input
-	    -> IO (SimplCount, [CoreBind])		-- New bindings
-
-simplifyPgm (imported_rule_ids, rule_lhs_fvs) 
-	    sw_chkr us binds
-  = do {
-	beginPass "Simplify";
-
-	-- Glom all binds together in one Rec, in case any
-	-- transformations have introduced any new dependencies
-	let { recd_binds = [Rec (flattenBinds binds)] };
-
-	(termination_msg, it_count, counts_out, binds') <- iteration us 1 zeroSimplCount recd_binds;
-
-	dumpIfSet (opt_D_verbose_core2core && opt_D_dump_simpl_stats)
-		  "Simplifier statistics"
-		  (vcat [text termination_msg <+> text "after" <+> ppr it_count <+> text "iterations",
-			 text "",
-			 pprSimplCount counts_out]);
-
-	endPass "Simplify" 
-		(opt_D_verbose_core2core && not opt_D_dump_simpl_iterations)
-		binds' ;
-
-	return (counts_out, binds')
-    }
-  where
-    max_iterations = getSimplIntSwitch sw_chkr MaxSimplifierIterations
-    black_list_fn  = blackListed rule_lhs_fvs (intSwitchSet sw_chkr SimplInlinePhase)
-
-    core_iter_dump binds | opt_D_verbose_core2core = pprCoreBindings binds
-		         | otherwise		   = empty
-
-    iteration us iteration_no counts binds
-      = do {
-		-- Occurrence analysis
-	   let { tagged_binds = _scc_ "OccAnal" occurAnalyseBinds binds } ;
-
-	   dumpIfSet opt_D_dump_occur_anal "Occurrence analysis"
-		     (pprCoreBindings tagged_binds);
-
-		-- Simplify
-	   let { (binds', counts') = initSmpl sw_chkr us1 imported_rule_ids 
-					      black_list_fn 
-					      (simplTopBinds tagged_binds);
-	         all_counts        = counts `plusSimplCount` counts'
-	       } ;
-
-		-- Stop if nothing happened; don't dump output
-	   if isZeroSimplCount counts' then
-		return ("Simplifier reached fixed point", iteration_no, all_counts, binds')
-	   else do {
-
-		-- Dump the result of this iteration
-	   dumpIfSet opt_D_dump_simpl_iterations
-		     ("Simplifier iteration " ++ show iteration_no 
-		      ++ " out of " ++ show max_iterations)
-		     (pprSimplCount counts') ;
-
-	   if opt_D_dump_simpl_iterations then
-		endPass ("Simplifier iteration " ++ show iteration_no ++ " result")
-			opt_D_verbose_core2core
-			binds'
-	   else
-		return [] ;
-
-		-- Stop if we've run out of iterations
-	   if iteration_no == max_iterations then
-		do {
-		    if  max_iterations > 2 then
-			    hPutStr stderr ("NOTE: Simplifier still going after " ++ 
-				    show max_iterations ++ 
-				    " iterations; bailing out.\n")
-		    else return ();
-
-		    return ("Simplifier baled out", iteration_no, all_counts, binds')
-		}
-
-		-- Else loop
-  	   else iteration us2 (iteration_no + 1) all_counts binds'
-	}  }
-      where
-  	  (us1, us2) = splitUniqSupply us
-\end{code}
-
-
-%************************************************************************
-%*									*
-\subsection{PostSimplification}
-%*									*
-%************************************************************************
-
-Several tasks are performed by the post-simplification pass
-
-1.  Make the representation of NoRep literals explicit, and
-    float their bindings to the top level.  We only do the floating
-    part for NoRep lits inside a lambda (else no gain).  We need to
-    take care with	let x = "foo" in e
-    that we don't end up with a silly binding
-			let x = y in e
-    with a floated "foo".  What a bore.
-    
-4. Do eta reduction for lambda abstractions appearing in:
-	- the RHS of case alternatives
-	- the body of a let
-
-   These will otherwise turn into local bindings during Core->STG;
-   better to nuke them if possible.  (In general the simplifier does
-   eta expansion not eta reduction, up to this point.  It does eta
-   on the RHSs of bindings but not the RHSs of case alternatives and
-   let bodies)
-
-
-------------------- NOT DONE ANY MORE ------------------------
-[March 98] Indirections are now elimianted by the occurrence analyser
-1.  Eliminate indirections.  The point here is to transform
-	x_local = E
-	x_exported = x_local
-    ==>
-	x_exported = E
-
-[Dec 98] [Not now done because there is no penalty in the code
-	  generator for using the former form]
-2.  Convert
-	case x of {...; x' -> ...x'...}
-    ==>
-	case x of {...; _  -> ...x... }
-    See notes in SimplCase.lhs, near simplDefault for the reasoning here.
---------------------------------------------------------------
-
-Special case
-~~~~~~~~~~~~
-
-NOT ENABLED AT THE MOMENT (because the floated Ids are global-ish
-things, and we need local Ids for non-floated stuff):
-
-  Don't float stuff out of a binder that's marked as a bottoming Id.
-  Reason: it doesn't do any good, and creates more CAFs that increase
-  the size of SRTs.
-
-eg.
-
-	f = error "string"
-
-is translated to
-
-	f' = unpackCString# "string"
-	f = error f'
-
-hence f' and f become CAFs.  Instead, the special case for
-tidyTopBinding below makes sure this comes out as
-
-	f = let f' = unpackCString# "string" in error f'
-
-and we can safely ignore f as a CAF, since it can only ever be entered once.
-
-
-
-\begin{code}
-doPostSimplification :: UniqSupply -> [CoreBind] -> IO [CoreBind]
-doPostSimplification us binds_in
-  = do
-	beginPass "Post-simplification pass"
-	let binds_out = initPM us (postSimplTopBinds binds_in)
-	endPass "Post-simplification pass" opt_D_verbose_core2core binds_out
-
-postSimplTopBinds :: [CoreBind] -> PostM [CoreBind]
-postSimplTopBinds binds
-  = mapPM postSimplTopBind binds	`thenPM` \ binds' ->
-    returnPM (bagToList (unionManyBags binds'))
-
-postSimplTopBind :: CoreBind -> PostM (Bag CoreBind)
-postSimplTopBind (NonRec bndr rhs)
-  | isBottomingId bndr		-- Don't lift out floats for bottoming Ids
-				-- See notes above
-  = getFloatsPM (postSimplExpr rhs)	`thenPM` \ (rhs', floats) ->
-    returnPM (unitBag (NonRec bndr (foldrBag Let rhs' floats)))
-
-postSimplTopBind bind
-  = getFloatsPM (postSimplBind bind)	`thenPM` \ (bind', floats) ->
-    returnPM (floats `snocBag` bind')
-
-postSimplBind (NonRec bndr rhs)
-  = postSimplExpr rhs		`thenPM` \ rhs' ->
-    returnPM (NonRec bndr rhs')
-
-postSimplBind (Rec pairs)
-  = mapPM postSimplExpr rhss	`thenPM` \ rhss' ->
-    returnPM (Rec (bndrs `zip` rhss'))
-  where
-    (bndrs, rhss) = unzip pairs
-\end{code}
-
-
-Expressions
-~~~~~~~~~~~
-\begin{code}
-postSimplExpr (Var v)   = returnPM (Var v)
-postSimplExpr (Type ty) = returnPM (Type ty)
-
-postSimplExpr (App fun arg)
-  = postSimplExpr fun	`thenPM` \ fun' ->
-    postSimplExpr arg	`thenPM` \ arg' ->
-    returnPM (App fun' arg')
-
-postSimplExpr (Con (Literal lit) args)
-  = ASSERT( null args )
-    litToRep lit	`thenPM` \ (lit_ty, lit_expr) ->
-    getInsideLambda	`thenPM` \ in_lam ->
-    if in_lam && not (exprIsTrivial lit_expr) then
-	-- It must have been a no-rep literal with a
-	-- non-trivial representation; and we're inside a lambda;
-	-- so float it to the top
-	addTopFloat lit_ty lit_expr	`thenPM` \ v ->
-	returnPM (Var v)
-    else
-	returnPM lit_expr
-
-postSimplExpr (Con con args)
-  = mapPM postSimplExpr args	`thenPM` \ args' ->
-    returnPM (Con con args')
-
-postSimplExpr (Lam bndr body)
-  = insideLambda bndr		$
-    postSimplExpr body		`thenPM` \ body' ->
-    returnPM (Lam bndr body')
-
-postSimplExpr (Let bind body)
-  = postSimplBind bind		`thenPM` \ bind' ->
-    postSimplExprEta body	`thenPM` \ body' ->
-    returnPM (Let bind' body')
-
-postSimplExpr (Note note body)
-  = postSimplExprEta body	`thenPM` \ body' ->
-    returnPM (Note note body')
-
-postSimplExpr (Case scrut case_bndr alts)
-  = postSimplExpr scrut			`thenPM` \ scrut' ->
-    mapPM ps_alt alts			`thenPM` \ alts' ->
-    returnPM (Case scrut' case_bndr alts')
-  where
-    ps_alt (con,bndrs,rhs) = postSimplExprEta rhs	`thenPM` \ rhs' ->
-			     returnPM (con, bndrs, rhs')
-
-postSimplExprEta e = postSimplExpr e	`thenPM` \ e' ->
-		     returnPM (etaCoreExpr e')
-\end{code}
-
-
-%************************************************************************
-%*									*
-\subsection[coreToStg-lits]{Converting literals}
-%*									*
-%************************************************************************
-
-Literals: the NoRep kind need to be de-no-rep'd.
-We always replace them with a simple variable, and float a suitable
-binding out to the top level.
-
-\begin{code}
-litToRep :: Literal -> PostM (Type, CoreExpr)
-
-litToRep (NoRepStr s ty)
-  = returnPM (ty, rhs)
-  where
-    rhs = if (any is_NUL (_UNPK_ s))
-
-	  then	 -- Must cater for NULs in literal string
-		mkApps (Var unpackCString2Id)
-		       [mkLit (MachStr s),
-		      	mkLit (mkMachInt (toInteger (_LENGTH_ s)))]
-
-	  else	-- No NULs in the string
-		App (Var unpackCStringId) (mkLit (MachStr s))
-
-    is_NUL c = c == '\0'
-\end{code}
-
-If an Integer is small enough (Haskell implementations must support
-Ints in the range $[-2^29+1, 2^29-1]$), wrap it up in @int2Integer@;
-otherwise, wrap with @addr2Integer@.
-
-\begin{code}
-litToRep (NoRepInteger i integer_ty)
-  = returnPM (integer_ty, rhs)
-  where
-    rhs | i > tARGET_MIN_INT &&		-- Small enough, so start from an Int
-	  i < tARGET_MAX_INT
-	= Con (DataCon smallIntegerDataCon) [Con (Literal (mkMachInt i)) []]
-  
-  	| otherwise 			-- Big, so start from a string
-	= App (Var addr2IntegerId) (Con (Literal (MachStr (_PK_ (show i)))) [])
-
-
-litToRep (NoRepRational r rational_ty)
-  = postSimplExpr (mkLit (NoRepInteger (numerator   r) integer_ty))	`thenPM` \ num_arg ->
-    postSimplExpr (mkLit (NoRepInteger (denominator r) integer_ty))	`thenPM` \ denom_arg ->
-    returnPM (rational_ty, mkConApp ratio_data_con [Type integer_ty, num_arg, denom_arg])
-  where
-    (ratio_data_con, integer_ty)
-      = case (splitAlgTyConApp_maybe rational_ty) of
-	  Just (tycon, [i_ty], [con])
-	    -> ASSERT(isIntegerTy i_ty && getUnique tycon == ratioTyConKey)
-	       (con, i_ty)
-
-	  _ -> (panic "ratio_data_con", panic "integer_ty")
-
-litToRep other_lit = returnPM (literalType other_lit, mkLit other_lit)
-\end{code}
-
-
-%************************************************************************
-%*									*
-\subsection{The monad}
-%*									*
-%************************************************************************
-
-\begin{code}
-type PostM a =  Bool				-- True <=> inside a *value* lambda
-	     -> (UniqSupply, Bag CoreBind)	-- Unique supply and Floats in 
-	     -> (a, (UniqSupply, Bag CoreBind))
-
-initPM :: UniqSupply -> PostM a -> a
-initPM us m
-  = case m False {- not inside lambda -} (us, emptyBag) of 
-	(result, _) -> result
-
-returnPM v in_lam usf = (v, usf)
-thenPM m k in_lam usf = case m in_lam usf of
-			 	  (r, usf') -> k r in_lam usf'
-
-mapPM f []     = returnPM []
-mapPM f (x:xs) = f x		`thenPM` \ r ->
-		 mapPM f xs	`thenPM` \ rs ->
-		 returnPM (r:rs)
-
-insideLambda :: CoreBndr -> PostM a -> PostM a
-insideLambda bndr m in_lam usf | isId bndr = m True   usf
-			       | otherwise = m in_lam usf
-
-getInsideLambda :: PostM Bool
-getInsideLambda in_lam usf = (in_lam, usf)
-
-getFloatsPM :: PostM a -> PostM (a, Bag CoreBind)
-getFloatsPM m in_lam (us, floats)
-  = let
-	(a, (us', floats')) = m in_lam (us, emptyBag)
-    in
-    ((a, floats'), (us', floats))
-
-addTopFloat :: Type -> CoreExpr -> PostM Id
-addTopFloat lit_ty lit_rhs in_lam (us, floats)
-  = let
-        (us1, us2) = splitUniqSupply us
-	uniq	   = uniqFromSupply us1
-        lit_id     = mkSysLocal SLIT("lf") uniq lit_ty
-    in
-    (lit_id, (us2, floats `snocBag` NonRec lit_id lit_rhs))
-\end{code}
-
-
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+%
+\section[SimplCore]{Driver for simplifying @Core@ programs}
+
+\begin{code}
+module SimplCore ( core2core ) where
+
+#include "HsVersions.h"
+
+import CmdLineOpts	( CoreToDo(..), SimplifierSwitch(..), 
+			  SwitchResult(..), switchIsOn, intSwitchSet,
+			  opt_D_dump_occur_anal, opt_D_dump_rules,
+			  opt_D_dump_simpl_iterations,
+			  opt_D_dump_simpl_stats,
+			  opt_D_dump_simpl, opt_D_dump_rules,
+			  opt_D_verbose_core2core,
+			  opt_D_dump_occur_anal,
+                          opt_UsageSPOn,
+			)
+import CoreLint		( beginPass, endPass )
+import CoreTidy		( tidyCorePgm )
+import CoreSyn
+import CSE		( cseProgram )
+import Rules		( RuleBase, ProtoCoreRule(..), pprProtoCoreRule, prepareRuleBase, orphanRule )
+import CoreUnfold
+import PprCore		( pprCoreBindings )
+import OccurAnal	( occurAnalyseBinds )
+import CoreUtils	( exprIsTrivial, coreExprType )
+import Simplify		( simplTopBinds, simplExpr )
+import SimplUtils	( etaCoreExpr, findDefault, simplBinders )
+import SimplMonad
+import Const		( Con(..), Literal(..), literalType, mkMachInt )
+import ErrUtils		( dumpIfSet )
+import FloatIn		( floatInwards )
+import FloatOut		( floatOutwards )
+import Id		( Id, mkSysLocal, mkVanillaId, isBottomingId,
+			  idType, setIdType, idName, idInfo, setIdNoDiscard
+			)
+import VarEnv
+import VarSet
+import Module		( Module )
+import Name		( mkLocalName, tidyOccName, tidyTopName, 
+			  NamedThing(..), OccName
+			)
+import TyCon		( TyCon, isDataTyCon )
+import PrimOp		( PrimOp(..) )
+import PrelInfo		( unpackCStringId, unpackCString2Id, addr2IntegerId )
+import Type		( Type, splitAlgTyConApp_maybe, 
+			  isUnLiftedType,
+			  tidyType, tidyTypes, tidyTopType, tidyTyVar, tidyTyVars,
+			  Type
+			)
+import TysWiredIn	( smallIntegerDataCon, isIntegerTy )
+import LiberateCase	( liberateCase )
+import SAT		( doStaticArgs )
+import Specialise	( specProgram)
+import UsageSPInf       ( doUsageSPInf )
+import StrictAnal	( saBinds )
+import WorkWrap	        ( wwTopBinds )
+import CprAnalyse       ( cprAnalyse )
+
+import Unique		( Unique, Uniquable(..),
+			  ratioTyConKey
+		        )
+import UniqSupply	( UniqSupply, mkSplitUniqSupply, splitUniqSupply, uniqFromSupply )
+import Constants	( tARGET_MIN_INT, tARGET_MAX_INT )
+import Util		( mapAccumL )
+import SrcLoc		( noSrcLoc )
+import Bag
+import Maybes
+import IO		( hPutStr, stderr )
+import Outputable
+
+import Ratio 		( numerator, denominator )
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection{The driver for the simplifier}
+%*									*
+%************************************************************************
+
+\begin{code}
+core2core :: [CoreToDo]		-- Spec of what core-to-core passes to do
+	  -> [CoreBind]		-- Binds in
+	  -> [ProtoCoreRule]	-- Rules
+	  -> IO ([CoreBind], [ProtoCoreRule])
+
+core2core core_todos binds rules
+  = do
+	us <-  mkSplitUniqSupply 's'
+	let (cp_us, us1)   = splitUniqSupply us
+	    (ru_us, ps_us) = splitUniqSupply us1
+
+        better_rules <- simplRules ru_us rules binds
+
+	let (binds1, rule_base) = prepareRuleBase binds better_rules
+
+	-- Do the main business
+	(stats, processed_binds) <- doCorePasses zeroSimplCount cp_us binds1 
+						 rule_base core_todos
+
+	dumpIfSet opt_D_dump_simpl_stats
+		  "Grand total simplifier statistics"
+		  (pprSimplCount stats)
+
+	-- Do the post-simplification business
+	post_simpl_binds <- doPostSimplification ps_us processed_binds
+
+	-- Return results
+	return (post_simpl_binds, filter orphanRule better_rules)
+   
+
+doCorePasses stats us binds irs []
+  = return (stats, binds)
+
+doCorePasses stats us binds irs (to_do : to_dos) 
+  = do
+	let (us1, us2) =  splitUniqSupply us
+	(stats1, binds1) <- doCorePass us1 binds irs to_do
+	doCorePasses (stats `plusSimplCount` stats1) us2 binds1 irs to_dos
+
+doCorePass us binds rb (CoreDoSimplify sw_chkr) = _scc_ "Simplify"      simplifyPgm rb sw_chkr us binds
+doCorePass us binds rb CoreCSE		        = _scc_ "CommonSubExpr" noStats (cseProgram binds)
+doCorePass us binds rb CoreLiberateCase	        = _scc_ "LiberateCase"  noStats (liberateCase binds)
+doCorePass us binds rb CoreDoFloatInwards       = _scc_ "FloatInwards"  noStats (floatInwards binds)
+doCorePass us binds rb CoreDoFullLaziness       = _scc_ "FloatOutwards" noStats (floatOutwards us binds)
+doCorePass us binds rb CoreDoStaticArgs	        = _scc_ "StaticArgs"    noStats (doStaticArgs us binds)
+doCorePass us binds rb CoreDoStrictness	        = _scc_ "Stranal"       noStats (saBinds binds)
+doCorePass us binds rb CoreDoWorkerWrapper      = _scc_ "WorkWrap"      noStats (wwTopBinds us binds)
+doCorePass us binds rb CoreDoSpecialising       = _scc_ "Specialise"    noStats (specProgram us binds)
+doCorePass us binds rb CoreDoCPResult	        = _scc_ "CPResult"      noStats (cprAnalyse binds)
+doCorePass us binds rb CoreDoPrintCore	        = _scc_ "PrintCore"     noStats (printCore binds)
+doCorePass us binds rb CoreDoUSPInf
+  = _scc_ "CoreUsageSPInf" 
+    if opt_UsageSPOn then
+      noStats (doUsageSPInf us binds)
+    else
+      trace "WARNING: ignoring requested -fusagesp pass; requires -fusagesp-on" $
+      noStats (return binds)
+
+printCore binds = do dumpIfSet True "Print Core"
+			       (pprCoreBindings binds)
+		     return binds
+
+noStats thing = do { result <- thing; return (zeroSimplCount, result) }
+\end{code}
+
+
+%************************************************************************
+%*									*
+\subsection{Dealing with rules}
+%*									*
+%************************************************************************
+
+We must do some gentle simplifiation on the template (but not the RHS)
+of each rule.  The case that forced me to add this was the fold/build rule,
+which without simplification looked like:
+	fold k z (build (/\a. g a))  ==>  ...
+This doesn't match unless you do eta reduction on the build argument.
+
+\begin{code}
+simplRules :: UniqSupply -> [ProtoCoreRule] -> [CoreBind] -> IO [ProtoCoreRule]
+simplRules us rules binds
+  = do  let (better_rules,_) = initSmpl sw_chkr us bind_vars black_list_all (mapSmpl simplRule rules)
+	
+	dumpIfSet opt_D_dump_rules
+		  "Transformation rules"
+		  (vcat (map pprProtoCoreRule better_rules))
+
+	return better_rules
+  where
+    black_list_all v = True 		-- This stops all inlining
+    sw_chkr any = SwBool False		-- A bit bogus
+
+	-- Boringly, we need to gather the in-scope set.
+	-- Typically this thunk won't even be force, but the test in
+	-- simpVar fails if it isn't right, and it might conceivably matter
+    bind_vars = foldr (unionVarSet . mkVarSet . bindersOf) emptyVarSet binds
+
+
+simplRule rule@(ProtoCoreRule is_local id (Rule name bndrs args rhs))
+  | not is_local
+  = returnSmpl rule	-- No need to fiddle with imported rules
+  | otherwise
+  = simplBinders bndrs			$ \ bndrs' -> 
+    mapSmpl simplExpr args		`thenSmpl` \ args' ->
+    simplExpr rhs			`thenSmpl` \ rhs' ->
+    returnSmpl (ProtoCoreRule is_local id (Rule name bndrs' args' rhs'))
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection{The driver for the simplifier}
+%*									*
+%************************************************************************
+
+\begin{code}
+simplifyPgm :: RuleBase
+	    -> (SimplifierSwitch -> SwitchResult)
+	    -> UniqSupply
+	    -> [CoreBind]				-- Input
+	    -> IO (SimplCount, [CoreBind])		-- New bindings
+
+simplifyPgm (imported_rule_ids, rule_lhs_fvs) 
+	    sw_chkr us binds
+  = do {
+	beginPass "Simplify";
+
+	-- Glom all binds together in one Rec, in case any
+	-- transformations have introduced any new dependencies
+	let { recd_binds = [Rec (flattenBinds binds)] };
+
+	(termination_msg, it_count, counts_out, binds') <- iteration us 1 zeroSimplCount recd_binds;
+
+	dumpIfSet (opt_D_verbose_core2core && opt_D_dump_simpl_stats)
+		  "Simplifier statistics"
+		  (vcat [text termination_msg <+> text "after" <+> ppr it_count <+> text "iterations",
+			 text "",
+			 pprSimplCount counts_out]);
+
+	endPass "Simplify" 
+		(opt_D_verbose_core2core && not opt_D_dump_simpl_iterations)
+		binds' ;
+
+	return (counts_out, binds')
+    }
+  where
+    max_iterations = getSimplIntSwitch sw_chkr MaxSimplifierIterations
+    black_list_fn  = blackListed rule_lhs_fvs (intSwitchSet sw_chkr SimplInlinePhase)
+
+    core_iter_dump binds | opt_D_verbose_core2core = pprCoreBindings binds
+		         | otherwise		   = empty
+
+    iteration us iteration_no counts binds
+      = do {
+		-- Occurrence analysis
+	   let { tagged_binds = _scc_ "OccAnal" occurAnalyseBinds binds } ;
+
+	   dumpIfSet opt_D_dump_occur_anal "Occurrence analysis"
+		     (pprCoreBindings tagged_binds);
+
+		-- Simplify
+	   let { (binds', counts') = initSmpl sw_chkr us1 imported_rule_ids 
+					      black_list_fn 
+					      (simplTopBinds tagged_binds);
+	         all_counts        = counts `plusSimplCount` counts'
+	       } ;
+
+		-- Stop if nothing happened; don't dump output
+	   if isZeroSimplCount counts' then
+		return ("Simplifier reached fixed point", iteration_no, all_counts, binds')
+	   else do {
+
+		-- Dump the result of this iteration
+	   dumpIfSet opt_D_dump_simpl_iterations
+		     ("Simplifier iteration " ++ show iteration_no 
+		      ++ " out of " ++ show max_iterations)
+		     (pprSimplCount counts') ;
+
+	   if opt_D_dump_simpl_iterations then
+		endPass ("Simplifier iteration " ++ show iteration_no ++ " result")
+			opt_D_verbose_core2core
+			binds'
+	   else
+		return [] ;
+
+		-- Stop if we've run out of iterations
+	   if iteration_no == max_iterations then
+		do {
+		    if  max_iterations > 2 then
+			    hPutStr stderr ("NOTE: Simplifier still going after " ++ 
+				    show max_iterations ++ 
+				    " iterations; bailing out.\n")
+		    else return ();
+
+		    return ("Simplifier baled out", iteration_no, all_counts, binds')
+		}
+
+		-- Else loop
+  	   else iteration us2 (iteration_no + 1) all_counts binds'
+	}  }
+      where
+  	  (us1, us2) = splitUniqSupply us
+\end{code}
+
+
+%************************************************************************
+%*									*
+\subsection{PostSimplification}
+%*									*
+%************************************************************************
+
+Several tasks are performed by the post-simplification pass
+
+1.  Make the representation of NoRep literals explicit, and
+    float their bindings to the top level.  We only do the floating
+    part for NoRep lits inside a lambda (else no gain).  We need to
+    take care with	let x = "foo" in e
+    that we don't end up with a silly binding
+			let x = y in e
+    with a floated "foo".  What a bore.
+    
+4. Do eta reduction for lambda abstractions appearing in:
+	- the RHS of case alternatives
+	- the body of a let
+
+   These will otherwise turn into local bindings during Core->STG;
+   better to nuke them if possible.  (In general the simplifier does
+   eta expansion not eta reduction, up to this point.  It does eta
+   on the RHSs of bindings but not the RHSs of case alternatives and
+   let bodies)
+
+
+------------------- NOT DONE ANY MORE ------------------------
+[March 98] Indirections are now elimianted by the occurrence analyser
+1.  Eliminate indirections.  The point here is to transform
+	x_local = E
+	x_exported = x_local
+    ==>
+	x_exported = E
+
+[Dec 98] [Not now done because there is no penalty in the code
+	  generator for using the former form]
+2.  Convert
+	case x of {...; x' -> ...x'...}
+    ==>
+	case x of {...; _  -> ...x... }
+    See notes in SimplCase.lhs, near simplDefault for the reasoning here.
+--------------------------------------------------------------
+
+Special case
+~~~~~~~~~~~~
+
+NOT ENABLED AT THE MOMENT (because the floated Ids are global-ish
+things, and we need local Ids for non-floated stuff):
+
+  Don't float stuff out of a binder that's marked as a bottoming Id.
+  Reason: it doesn't do any good, and creates more CAFs that increase
+  the size of SRTs.
+
+eg.
+
+	f = error "string"
+
+is translated to
+
+	f' = unpackCString# "string"
+	f = error f'
+
+hence f' and f become CAFs.  Instead, the special case for
+tidyTopBinding below makes sure this comes out as
+
+	f = let f' = unpackCString# "string" in error f'
+
+and we can safely ignore f as a CAF, since it can only ever be entered once.
+
+
+
+\begin{code}
+doPostSimplification :: UniqSupply -> [CoreBind] -> IO [CoreBind]
+doPostSimplification us binds_in
+  = do
+	beginPass "Post-simplification pass"
+	let binds_out = initPM us (postSimplTopBinds binds_in)
+	endPass "Post-simplification pass" opt_D_verbose_core2core binds_out
+
+postSimplTopBinds :: [CoreBind] -> PostM [CoreBind]
+postSimplTopBinds binds
+  = mapPM postSimplTopBind binds	`thenPM` \ binds' ->
+    returnPM (bagToList (unionManyBags binds'))
+
+postSimplTopBind :: CoreBind -> PostM (Bag CoreBind)
+postSimplTopBind (NonRec bndr rhs)
+  | isBottomingId bndr		-- Don't lift out floats for bottoming Ids
+				-- See notes above
+  = getFloatsPM (postSimplExpr rhs)	`thenPM` \ (rhs', floats) ->
+    returnPM (unitBag (NonRec bndr (foldrBag Let rhs' floats)))
+
+postSimplTopBind bind
+  = getFloatsPM (postSimplBind bind)	`thenPM` \ (bind', floats) ->
+    returnPM (floats `snocBag` bind')
+
+postSimplBind (NonRec bndr rhs)
+  = postSimplExpr rhs		`thenPM` \ rhs' ->
+    returnPM (NonRec bndr rhs')
+
+postSimplBind (Rec pairs)
+  = mapPM postSimplExpr rhss	`thenPM` \ rhss' ->
+    returnPM (Rec (bndrs `zip` rhss'))
+  where
+    (bndrs, rhss) = unzip pairs
+\end{code}
+
+
+Expressions
+~~~~~~~~~~~
+\begin{code}
+postSimplExpr (Var v)   = returnPM (Var v)
+postSimplExpr (Type ty) = returnPM (Type ty)
+
+postSimplExpr (App fun arg)
+  = postSimplExpr fun	`thenPM` \ fun' ->
+    postSimplExpr arg	`thenPM` \ arg' ->
+    returnPM (App fun' arg')
+
+postSimplExpr (Con (Literal lit) args)
+  = ASSERT( null args )
+    litToRep lit	`thenPM` \ (lit_ty, lit_expr) ->
+    getInsideLambda	`thenPM` \ in_lam ->
+    if in_lam && not (exprIsTrivial lit_expr) then
+	-- It must have been a no-rep literal with a
+	-- non-trivial representation; and we're inside a lambda;
+	-- so float it to the top
+	addTopFloat lit_ty lit_expr	`thenPM` \ v ->
+	returnPM (Var v)
+    else
+	returnPM lit_expr
+
+postSimplExpr (Con con args)
+  = mapPM postSimplExpr args	`thenPM` \ args' ->
+    returnPM (Con con args')
+
+postSimplExpr (Lam bndr body)
+  = insideLambda bndr		$
+    postSimplExpr body		`thenPM` \ body' ->
+    returnPM (Lam bndr body')
+
+postSimplExpr (Let bind body)
+  = postSimplBind bind		`thenPM` \ bind' ->
+    postSimplExprEta body	`thenPM` \ body' ->
+    returnPM (Let bind' body')
+
+postSimplExpr (Note note body)
+  = postSimplExprEta body	`thenPM` \ body' ->
+    returnPM (Note note body')
+
+postSimplExpr (Case scrut case_bndr alts)
+  = postSimplExpr scrut			`thenPM` \ scrut' ->
+    mapPM ps_alt alts			`thenPM` \ alts' ->
+    returnPM (Case scrut' case_bndr alts')
+  where
+    ps_alt (con,bndrs,rhs) = postSimplExprEta rhs	`thenPM` \ rhs' ->
+			     returnPM (con, bndrs, rhs')
+
+postSimplExprEta e = postSimplExpr e	`thenPM` \ e' ->
+		     returnPM (etaCoreExpr e')
+\end{code}
+
+
+%************************************************************************
+%*									*
+\subsection[coreToStg-lits]{Converting literals}
+%*									*
+%************************************************************************
+
+Literals: the NoRep kind need to be de-no-rep'd.
+We always replace them with a simple variable, and float a suitable
+binding out to the top level.
+
+\begin{code}
+litToRep :: Literal -> PostM (Type, CoreExpr)
+
+litToRep (NoRepStr s ty)
+  = returnPM (ty, rhs)
+  where
+    rhs = if (any is_NUL (_UNPK_ s))
+
+	  then	 -- Must cater for NULs in literal string
+		mkApps (Var unpackCString2Id)
+		       [mkLit (MachStr s),
+		      	mkLit (mkMachInt (toInteger (_LENGTH_ s)))]
+
+	  else	-- No NULs in the string
+		App (Var unpackCStringId) (mkLit (MachStr s))
+
+    is_NUL c = c == '\0'
+\end{code}
+
+If an Integer is small enough (Haskell implementations must support
+Ints in the range $[-2^29+1, 2^29-1]$), wrap it up in @int2Integer@;
+otherwise, wrap with @addr2Integer@.
+
+\begin{code}
+litToRep (NoRepInteger i integer_ty)
+  = returnPM (integer_ty, rhs)
+  where
+    rhs | i > tARGET_MIN_INT &&		-- Small enough, so start from an Int
+	  i < tARGET_MAX_INT
+	= Con (DataCon smallIntegerDataCon) [Con (Literal (mkMachInt i)) []]
+  
+  	| otherwise 			-- Big, so start from a string
+	= App (Var addr2IntegerId) (Con (Literal (MachStr (_PK_ (show i)))) [])
+
+
+litToRep (NoRepRational r rational_ty)
+  = postSimplExpr (mkLit (NoRepInteger (numerator   r) integer_ty))	`thenPM` \ num_arg ->
+    postSimplExpr (mkLit (NoRepInteger (denominator r) integer_ty))	`thenPM` \ denom_arg ->
+    returnPM (rational_ty, mkConApp ratio_data_con [Type integer_ty, num_arg, denom_arg])
+  where
+    (ratio_data_con, integer_ty)
+      = case (splitAlgTyConApp_maybe rational_ty) of
+	  Just (tycon, [i_ty], [con])
+	    -> ASSERT(isIntegerTy i_ty && getUnique tycon == ratioTyConKey)
+	       (con, i_ty)
+
+	  _ -> (panic "ratio_data_con", panic "integer_ty")
+
+litToRep other_lit = returnPM (literalType other_lit, mkLit other_lit)
+\end{code}
+
+
+%************************************************************************
+%*									*
+\subsection{The monad}
+%*									*
+%************************************************************************
+
+\begin{code}
+type PostM a =  Bool				-- True <=> inside a *value* lambda
+	     -> (UniqSupply, Bag CoreBind)	-- Unique supply and Floats in 
+	     -> (a, (UniqSupply, Bag CoreBind))
+
+initPM :: UniqSupply -> PostM a -> a
+initPM us m
+  = case m False {- not inside lambda -} (us, emptyBag) of 
+	(result, _) -> result
+
+returnPM v in_lam usf = (v, usf)
+thenPM m k in_lam usf = case m in_lam usf of
+			 	  (r, usf') -> k r in_lam usf'
+
+mapPM f []     = returnPM []
+mapPM f (x:xs) = f x		`thenPM` \ r ->
+		 mapPM f xs	`thenPM` \ rs ->
+		 returnPM (r:rs)
+
+insideLambda :: CoreBndr -> PostM a -> PostM a
+insideLambda bndr m in_lam usf | isId bndr = m True   usf
+			       | otherwise = m in_lam usf
+
+getInsideLambda :: PostM Bool
+getInsideLambda in_lam usf = (in_lam, usf)
+
+getFloatsPM :: PostM a -> PostM (a, Bag CoreBind)
+getFloatsPM m in_lam (us, floats)
+  = let
+	(a, (us', floats')) = m in_lam (us, emptyBag)
+    in
+    ((a, floats'), (us', floats))
+
+addTopFloat :: Type -> CoreExpr -> PostM Id
+addTopFloat lit_ty lit_rhs in_lam (us, floats)
+  = let
+        (us1, us2) = splitUniqSupply us
+	uniq	   = uniqFromSupply us1
+        lit_id     = mkSysLocal SLIT("lf") uniq lit_ty
+    in
+    (lit_id, (us2, floats `snocBag` NonRec lit_id lit_rhs))
+\end{code}
+
+
diff --git a/ghc/compiler/simplCore/SimplMonad.lhs b/ghc/compiler/simplCore/SimplMonad.lhs
index c2771622e5a2c70149698e8d0ed0ca9375060756..5b5cde807223272b24b16a48c5eedcc08e56871f 100644
--- a/ghc/compiler/simplCore/SimplMonad.lhs
+++ b/ghc/compiler/simplCore/SimplMonad.lhs
@@ -221,7 +221,8 @@ contIsInteresting (Select _ _ alts _ _)       = not (just_default alts)
 contIsInteresting (CoerceIt _ cont)           = contIsInteresting cont
 contIsInteresting (ApplyTo _ (Type _) _ cont) = contIsInteresting cont
 contIsInteresting (ApplyTo _ _	      _ _)    = True
-contIsInteresting (ArgOf _ _ _)		      = True
+
+contIsInteresting (ArgOf _ _ _)		      = False
 	-- If this call is the arg of a strict function, the context
 	-- is a bit interesting.  If we inline here, we may get useful
 	-- evaluation information to avoid repeated evals: e.g.
@@ -229,6 +230,13 @@ contIsInteresting (ArgOf _ _ _)		      = True
 	-- Here the contIsInteresting makes the '*' keener to inline,
 	-- which in turn exposes a constructor which makes the '+' inline.
 	-- Assuming that +,* aren't small enough to inline regardless.
+	--
+	-- HOWEVER, I put this back to False when I discovered that strings
+	-- were getting inlined straight back into applications of 'error'
+	-- because the latter is strict.
+	--	s = "foo"
+	--	f = \x -> ...(error s)...
+
 contIsInteresting (InlinePlease _)	      = True
 contIsInteresting other		              = False
 
diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs
index 72c9e1a3cff7e3b046d320006543309e70116153..4ef7937e36b687a3501e0faf336e40742a6175f7 100644
--- a/ghc/compiler/simplCore/SimplUtils.lhs
+++ b/ghc/compiler/simplCore/SimplUtils.lhs
@@ -18,9 +18,7 @@ import BinderInfo
 import CmdLineOpts	( opt_SimplDoLambdaEtaExpansion, opt_SimplCaseMerge )
 import CoreSyn
 import CoreFVs		( exprFreeVars )
-import CoreUtils	( exprIsTrivial, cheapEqExpr, coreExprType,
-			  exprIsWHNF, FormSummary(..)
-			)
+import CoreUtils	( exprIsTrivial, cheapEqExpr, coreExprType, exprIsCheap	)
 import Subst		( substBndrs, substBndr, substIds )
 import Id		( Id, idType, getIdArity, isId, idName,
 			  getInlinePragma, setInlinePragma,
@@ -182,7 +180,7 @@ mkRhsTyLam tyvars body			-- Only does something if there's a let
     worth_it (Let _ e)	     = whnf_in_middle e
     worth_it other     	     = False
     whnf_in_middle (Let _ e) = whnf_in_middle e
-    whnf_in_middle e	     = exprIsWHNF e
+    whnf_in_middle e	     = exprIsCheap e
 
     main_tyvar_set = mkVarSet tyvars
 
diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs
index 189f0f6cfc8aef00af0e7e943dde31e3235c6e73..03ad9eb9308e860c57bf08fec812e2551074e071 100644
--- a/ghc/compiler/simplCore/Simplify.lhs
+++ b/ghc/compiler/simplCore/Simplify.lhs
@@ -43,9 +43,10 @@ import Const		( Con(..) )
 import Name		( isLocallyDefined )
 import CoreSyn
 import CoreFVs		( exprFreeVars )
-import CoreUnfold	( Unfolding(..), mkUnfolding, callSiteInline, 
-			  isEvaldUnfolding, blackListed )
-import CoreUtils	( cheapEqExpr, exprIsDupable, exprIsWHNF, exprIsTrivial,
+import CoreUnfold	( Unfolding, mkOtherCon, mkUnfolding, otherCons,
+			  callSiteInline, blackListed
+			)
+import CoreUtils	( cheapEqExpr, exprIsDupable, exprIsCheap, exprIsTrivial,
 			  coreExprType, coreAltsType, exprArity, exprIsValue,
 			  exprOkForSpeculation
 			)
@@ -619,8 +620,8 @@ simplRhs top_lvl float_ubx rhs_ty rhs rhs_se thing_inside
 	(floats_out, rhs'') | float_ubx = (floats, rhs')
 			    | otherwise	= splitFloats floats rhs' 
     in
-    if (isTopLevel top_lvl || exprIsWHNF rhs') && 	-- Float lets if (a) we're at the top level
-        not (null floats_out)				-- or 		 (b) it exposes a HNF
+    if (isTopLevel top_lvl || exprIsCheap rhs') && 	-- Float lets if (a) we're at the top level
+        not (null floats_out)				-- or 		 (b) it exposes a cheap (i.e. duplicatable) expression
     then
 	tickLetFloat floats_out				`thenSmpl_`
 		-- Do the float
@@ -1013,7 +1014,8 @@ rebuild scrut (Select _ bndr alts se cont)
 	-- Check that the scrutinee can be let-bound instead of case-bound
     && (   (isUnLiftedType (idType bndr) && 	-- It's unlifted and floatable
 	    exprOkForSpeculation scrut)		-- NB: scrut = an unboxed variable satisfies 
-	|| is_a_value scrut			-- It's a value
+	|| exprIsValue scrut			-- It's already evaluated
+	|| var_demanded_later scrut		-- It'll be demanded later
 
 --      || not opt_SimplPedanticBottoms)	-- Or we don't care!
 --	We used to allow improving termination by discarding cases, unless -fpedantic-bottoms was on,
@@ -1040,10 +1042,8 @@ rebuild scrut (Select _ bndr alts se cont)
     (rhs1:other_rhss)		 = [rhs | (_,_,rhs) <- alts]
     binders_unused (_, bndrs, _) = all isDeadBinder bndrs
 
-	-- Check whether or not scrut is known to be evaluted
-    is_a_value (Var v) =    isEvaldUnfolding (getIdUnfolding v)	-- It's been evaluated
-			 || isStrict (getIdDemandInfo bndr)	-- It's going to be evaluated later
-    is_a_value scrut   = exprIsValue scrut
+    var_demanded_later (Var v) = isStrict (getIdDemandInfo bndr)	-- It's going to be evaluated later
+    var_demanded_later other   = False
 \end{code}
 
 Case elimination [see the code above]
@@ -1165,9 +1165,7 @@ rebuild_case scrut case_bndr alts se cont
   where
 	-- scrut_cons tells what constructors the scrutinee can't possibly match
     scrut_cons = case scrut of
-		   Var v -> case getIdUnfolding v of
-				OtherCon cons -> cons
-				other	      -> []
+		   Var v -> otherCons (getIdUnfolding v)
 		   other -> []
 
 
@@ -1313,7 +1311,7 @@ simplAlts zap_occ_info scrut_cons case_bndr'' alts cont'
 	=	-- In the default case we record the constructors that the
 		-- case-binder *can't* be.
 		-- We take advantage of any OtherCon info in the case scrutinee
-	  modifyInScope (case_bndr'' `setIdUnfolding` OtherCon handled_cons)	$ 
+	  modifyInScope (case_bndr'' `setIdUnfolding` mkOtherCon handled_cons)	$ 
 	  simplExprC rhs cont'							`thenSmpl` \ rhs' ->
 	  returnSmpl (DEFAULT, [], rhs')
 
@@ -1346,9 +1344,9 @@ simplAlts zap_occ_info scrut_cons case_bndr'' alts cont'
 
     cat_evals [] [] = []
     cat_evals (v:vs) (str:strs)
-	| isTyVar v    = v				   : cat_evals vs (str:strs)
-	| isStrict str = (v' `setIdUnfolding` OtherCon []) : cat_evals vs strs
-	| otherwise    = v'				   : cat_evals vs strs
+	| isTyVar v    = v				     : cat_evals vs (str:strs)
+	| isStrict str = (v' `setIdUnfolding` mkOtherCon []) : cat_evals vs strs
+	| otherwise    = v'				     : cat_evals vs strs
 	where
 	  v' = zap_occ_info v
 \end{code}
diff --git a/ghc/compiler/specialise/Rules.lhs b/ghc/compiler/specialise/Rules.lhs
index c0e05c50859152cd5d101a404f9db61524887d75..99da2e2d705b43f5db82469860d2d7a8302be8fc 100644
--- a/ghc/compiler/specialise/Rules.lhs
+++ b/ghc/compiler/specialise/Rules.lhs
@@ -17,8 +17,8 @@ import CoreSyn		-- All of it
 import OccurAnal	( occurAnalyseExpr, tagBinders, UsageDetails )
 import BinderInfo	( markMany )
 import CoreFVs		( exprFreeVars, idRuleVars, ruleSomeLhsFreeVars )
-import CoreUnfold	( Unfolding(..) )
-import CoreUtils	( whnfOrBottom, eqExpr )
+import CoreUnfold	( isCheapUnfolding, unfoldingTemplate )
+import CoreUtils	( eqExpr )
 import PprCore		( pprCoreRule )
 import Subst		( Subst, InScopeSet, substBndr, lookupSubst, extendSubst,
 			  mkSubst, substEnv, setSubstEnv, emptySubst, isInScope,
@@ -296,12 +296,11 @@ match e1 (Let bind e2) tpl_vars kont subst
 -- (Its occurrence information is not necessarily up to date,
 --  so we don't use it.)
 match e1 (Var v2) tpl_vars kont subst
-  = case getIdUnfolding v2 of
-	CoreUnfolding form guidance unfolding
-	   |  whnfOrBottom form
-	   -> match e1 unfolding tpl_vars kont subst
+  | isCheapUnfolding unfolding
+  = match e1 (unfoldingTemplate unfolding) tpl_vars kont subst
+  where
+    unfolding = getIdUnfolding v2
 
-	other -> match_fail
 
 -- We can't cope with lets in the template
 
diff --git a/ghc/compiler/specialise/Specialise.lhs b/ghc/compiler/specialise/Specialise.lhs
index e8b1b5dbdf7125d756a2852f32b17ce3d74cfa1f..edc928b5b0903a3241de4e523e5ca033b3f69a65 100644
--- a/ghc/compiler/specialise/Specialise.lhs
+++ b/ghc/compiler/specialise/Specialise.lhs
@@ -878,11 +878,16 @@ specDefn subst calls (fn, rhs)
 			    mkTyApps (Var spec_f) (map mkTyVarTy poly_tyvars))
 
 		-- Add the { d1' = dx1; d2' = dx2 } usage stuff
-	   final_uds = foldr addDictBind rhs_uds (zipEqual "spec_call" rhs_dicts' call_ds)
+	   final_uds = foldr addDictBind rhs_uds (my_zipEqual "spec_call" rhs_dicts' call_ds)
 	in
         returnSM ((spec_f, spec_rhs),
 	          final_uds,
 		  spec_env_rule)
+
+      where
+	my_zipEqual doc xs ys 
+	 | length xs /= length ys = pprPanic "my_zipEqual" (ppr xs $$ ppr ys $$ (ppr fn <+> ppr call_ts) $$ ppr rhs)
+	 | otherwise		  = zipEqual doc xs ys
 \end{code}
 
 %************************************************************************
diff --git a/ghc/compiler/stranal/SaAbsInt.lhs b/ghc/compiler/stranal/SaAbsInt.lhs
index 37e9248d877718d82b723021f3e4dc369944441c..74155cf58c469e4e4cd61ee0fdefa3b37fd94b4d 100644
--- a/ghc/compiler/stranal/SaAbsInt.lhs
+++ b/ghc/compiler/stranal/SaAbsInt.lhs
@@ -17,7 +17,7 @@ module SaAbsInt (
 
 import CmdLineOpts	( opt_AllStrict, opt_NumbersStrict )
 import CoreSyn
-import CoreUnfold	( Unfolding(..) )
+import CoreUnfold	( Unfolding, maybeUnfoldingTemplate )
 import PrimOp		( primOpStrictness )
 import Id		( Id, idType, getIdStrictness, getIdUnfolding )
 import Const		( Con(..) )
@@ -350,12 +350,12 @@ evalAbsence other val = anyBot val
 				-- error's arg
 
 absId anal var env
-  = case (lookupAbsValEnv env var, getIdStrictness var, getIdUnfolding var) of
+  = case (lookupAbsValEnv env var, getIdStrictness var, maybeUnfoldingTemplate (getIdUnfolding var)) of
 
 	(Just abs_val, _, _) ->
 			abs_val	-- Bound in the environment
 
-	(Nothing, NoStrictnessInfo, CoreUnfolding _ _ unfolding) ->
+	(Nothing, NoStrictnessInfo, Just unfolding) ->
 			-- We have an unfolding for the expr
 			-- Assume the unfolding has no free variables since it
 			-- came from inside the Id
diff --git a/ghc/compiler/stranal/StrictAnal.lhs b/ghc/compiler/stranal/StrictAnal.lhs
index f3a2ad0eb7041ff9f0097045f4aaf33a080ffed5..904ea3e9aa13ad45072332f9fda2e0d568362042 100644
--- a/ghc/compiler/stranal/StrictAnal.lhs
+++ b/ghc/compiler/stranal/StrictAnal.lhs
@@ -324,10 +324,13 @@ addStrictnessInfoToId
 	-> Id			-- Augmented with strictness
 
 addStrictnessInfoToId str_val abs_val binder body
-  = case collectBinders body of
-	-- We could use 'collectBindersIgnoringNotes', but then the 
-	-- strictness info may have more items than the visible binders
-	-- used by WorkWrap.tryWW
+  = case collectBindersIgnoringNotes body of
+	-- It's imporant to use collectBindersIgnoringNotes, so that INLINE prags
+	-- don't inhibit strictness info.  In particular, foldr is marked INLINE,
+	-- but we still want it to be strict in its third arg, so that
+	--	foldr k z (case e of p -> build g) 
+	-- gets transformed to
+	--	case e of p -> foldr k z (build g)
 	(binders, rhs) -> binder `setIdStrictness` 
 			  mkStrictnessInfo strictness
 		where
diff --git a/ghc/compiler/stranal/WorkWrap.lhs b/ghc/compiler/stranal/WorkWrap.lhs
index 86d5d02b0e95750fb3d84bc2d0ce970c9656aac7..472cfd9f016535515411fdcaabdebb674b666337 100644
--- a/ghc/compiler/stranal/WorkWrap.lhs
+++ b/ghc/compiler/stranal/WorkWrap.lhs
@@ -217,24 +217,21 @@ tryWW non_rec fn_id rhs
   = returnUs [ (fn_id, rhs) ]
 
   | otherwise		-- Do w/w split
-  = let
-	(tyvars, wrap_args, body) = collectTyAndValBinders rhs
-    in
-    mkWwBodies tyvars wrap_args 
+  = mkWwBodies tyvars wrap_args 
 	       (coreExprType body)
-	       revised_wrap_args_info
+	       wrap_demands
 	       cpr_info
                                                 `thenUs` \ (wrap_fn, work_fn, work_demands) ->
     getUniqueUs					`thenUs` \ work_uniq ->
     let
 	work_rhs  = work_fn body
 	work_id   = mkWorkerId work_uniq fn_id (coreExprType work_rhs) `setIdStrictness`
-		    (if has_strictness_info then mkStrictnessInfo (work_demands, result_bot)
+		    (if has_strictness_info then mkStrictnessInfo (work_demands ++ remaining_arg_demands, result_bot)
 	                                    else noStrictnessInfo) 
 
 	wrap_rhs = wrap_fn work_id
 	wrap_id  = fn_id `setIdStrictness` 
-                         (if has_strictness_info then mkStrictnessInfo (revised_wrap_args_info, result_bot)
+                         (if has_strictness_info then mkStrictnessInfo (wrap_demands ++ remaining_arg_demands, result_bot)
 	                                         else noStrictnessInfo) 
                          `setIdWorkerInfo`	Just work_id
 			 `setIdArity`		exactArity (length wrap_args)
@@ -246,18 +243,26 @@ tryWW non_rec fn_id rhs
     returnUs ([(work_id, work_rhs), (wrap_id, wrap_rhs)])
 	-- Worker first, because wrapper mentions it
   where
+    (tyvars, wrap_args, body) = collectTyAndValBinders rhs
+    n_wrap_args		      = length wrap_args
+
     strictness_info     = getIdStrictness fn_id
     has_strictness_info = case strictness_info of
 				StrictnessInfo _ _ -> True
 				other		   -> False
 
-    StrictnessInfo wrap_args_info result_bot = strictness_info
+    StrictnessInfo arg_demands result_bot = strictness_info
 			
-    revised_wrap_args_info = if has_strictness_info 
-                               then setUnpackStrategy wrap_args_info
-                               else repeat wwLazy
+	-- NB: There maybe be more items in arg_demands than wrap_args, because
+	-- the strictness info is semantic and looks through InlineMe and Scc
+	-- Notes, whereas wrap_args does not
+    demands_for_visible_args = take n_wrap_args arg_demands
+    remaining_arg_demands    = drop n_wrap_args arg_demands
+
+    wrap_demands | has_strictness_info = setUnpackStrategy demands_for_visible_args
+		 | otherwise	       = repeat wwLazy
 
-    do_strict_ww = has_strictness_info && worthSplitting revised_wrap_args_info result_bot
+    do_strict_ww = has_strictness_info && worthSplitting wrap_demands result_bot
 
     cpr_info     = getIdCprInfo fn_id
     has_cpr_info = case cpr_info of
diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs
index 3049bbe579cde3134127a99daca4c74120f2bacf..794eb83876823639510ba37cc153d3edd6e95cc2 100644
--- a/ghc/compiler/typecheck/TcClassDcl.lhs
+++ b/ghc/compiler/typecheck/TcClassDcl.lhs
@@ -45,7 +45,7 @@ import CmdLineOpts      ( opt_GlasgowExts, opt_WarnMissingMethods )
 import MkId		( mkDictSelId, mkDataConId, mkDefaultMethodId )
 import DataCon		( mkDataCon, notMarkedStrict )
 import Id		( Id, setInlinePragma, getIdUnfolding, idType, idName )
-import CoreUnfold	( getUnfoldingTemplate )
+import CoreUnfold	( unfoldingTemplate )
 import IdInfo
 import Name		( Name, nameOccName, isLocallyDefined, NamedThing(..) )
 import NameSet		( emptyNameSet )
@@ -347,7 +347,7 @@ tcClassDecl2 (ClassDecl context class_name
 	(tyvars, sc_theta, sc_sel_ids, op_sel_ids, defm_ids) = classBigSig clas
 
 	-- The selector binds are already in the selector Id's unfoldings
-	sel_binds = [ CoreMonoBind sel_id (getUnfoldingTemplate (getIdUnfolding sel_id))
+	sel_binds = [ CoreMonoBind sel_id (unfoldingTemplate (getIdUnfolding sel_id))
 		    | sel_id <- sc_sel_ids ++ op_sel_ids 
 		    ]
     in
diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs
index b043f7dc5bec2f1248df4a077b42191ea13f7ba0..118e58e20dccff530987c58ec3171faa1a57da90 100644
--- a/ghc/compiler/typecheck/TcGenDeriv.lhs
+++ b/ghc/compiler/typecheck/TcGenDeriv.lhs
@@ -306,7 +306,8 @@ JJQC-30-Nov-1997
 gen_Ord_binds :: TyCon -> RdrNameMonoBinds
 
 gen_Ord_binds tycon
-  = defaulted `AndMonoBinds` compare
+  = compare 	-- `AndMonoBinds` compare	
+		-- The default declaration in PrelBase handles this
   where
     tycon_loc = getSrcLoc tycon
     --------------------------------------------------------------------
@@ -387,6 +388,8 @@ gen_Ord_binds tycon
 								-- Tags are equal, no args => return EQ
     --------------------------------------------------------------------
 
+{- Not necessary: the default decls in PrelBase handle these 
+
 defaulted = foldr1 AndMonoBinds [lt, le, ge, gt, max_, min_]
 
 lt = mk_easy_FunMonoBind mkGeneratedSrcLoc lt_RDR [a_Pat, b_Pat] [] (
@@ -402,6 +405,7 @@ max_ = mk_easy_FunMonoBind mkGeneratedSrcLoc max_RDR [a_Pat, b_Pat] [] (
 	    compare_Case b_Expr a_Expr a_Expr a_Expr b_Expr)
 min_ = mk_easy_FunMonoBind mkGeneratedSrcLoc min_RDR [a_Pat, b_Pat] [] (
 	    compare_Case a_Expr b_Expr b_Expr a_Expr b_Expr)
+-}
 \end{code}
 
 %************************************************************************
diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs
index 6b8328b5a2d79235160d64e7030218617a0e03ac..0e15147dd9ce3c461f65d413b8d46f28c82a65f6 100644
--- a/ghc/compiler/typecheck/TcIfaceSig.lhs
+++ b/ghc/compiler/typecheck/TcIfaceSig.lhs
@@ -98,7 +98,7 @@ tcIdInfo unf_env name ty info info_ins
 		-- maybe_expr doesn't get looked at if the unfolding
 		-- is never inspected; so the typecheck doesn't even happen
 		unfold_info = case maybe_expr' of
-				Nothing    -> NoUnfolding
+				Nothing    -> noUnfolding
 				Just expr' -> mkUnfolding expr' 
 		info1 = info `setUnfoldingInfo` unfold_info
 		info2 = info1 `setInlinePragInfo` inline_prag
diff --git a/ghc/compiler/typecheck/TcInstUtil.lhs b/ghc/compiler/typecheck/TcInstUtil.lhs
index 315f601a956028b8257b72545cf266ea7efec241..830140ab4827547058966338d8dfbbd9dfc4789e 100644
--- a/ghc/compiler/typecheck/TcInstUtil.lhs
+++ b/ghc/compiler/typecheck/TcInstUtil.lhs
@@ -22,10 +22,10 @@ import Inst		( InstanceMapper )
 
 import Bag		( bagToList, Bag )
 import Class		( Class )
-import Var		( TyVar, Id )
+import Var		( TyVar, Id, idName )
 import InstEnv		( InstEnv, emptyInstEnv, addToInstEnv )
 import Maybes		( MaybeErr(..), mkLookupFunDef )
-import Name		( getSrcLoc )
+import Name		( getSrcLoc, nameModule, isLocallyDefined )
 import SrcLoc		( SrcLoc )
 import Type		( ThetaType, Type )
 import PprType		( pprConstraint )
@@ -122,8 +122,8 @@ addClassInstance
   = 	-- Add the instance to the class's instance environment
     case addToInstEnv opt_AllowOverlappingInstances 
 		      class_inst_env inst_tyvars inst_tys dfun_id of
-	Failed (ty', dfun_id')    -> addErrTc (dupInstErr clas (inst_tys, src_loc) 
-							       (ty', getSrcLoc dfun_id'))
+	Failed (tys', dfun_id')    -> addErrTc (dupInstErr clas (inst_tys, dfun_id) 
+							        (tys',     dfun_id'))
 						`thenNF_Tc_`
 				     returnNF_Tc class_inst_env
 
@@ -131,10 +131,13 @@ addClassInstance
 \end{code}
 
 \begin{code}
-dupInstErr clas info1@(tys1, locn1) info2@(tys2, locn2)
+dupInstErr clas info1@(tys1, dfun1) info2@(tys2, dfun2)
 	-- Overlapping/duplicate instances for given class; msg could be more glamourous
   = hang (ptext SLIT("Duplicate or overlapping instance declarations"))
          4 (sep [ptext SLIT("for") <+> quotes (pprConstraint clas tys1),
-		 nest 4 (sep [ptext SLIT("at")  <+> ppr locn1,
-		    	      ptext SLIT("and") <+> ppr locn2])])
+		 nest 4 (sep [ppr_loc dfun1, ptext SLIT("and") <+> ppr_loc dfun2])])
+  where
+    ppr_loc dfun
+	| isLocallyDefined dfun = ptext SLIT("defined at")  	     <+> ppr (getSrcLoc dfun)
+	| otherwise		= ptext SLIT("imported from module") <+> quotes (ppr (nameModule (idName dfun)))
 \end{code}
diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs
index 45984b74aac347fd8c1c2db163f70adfcb5d3a02..ed9436654ef2cc71aa50a98afd3a320eca5110e3 100644
--- a/ghc/compiler/typecheck/TcTyDecls.lhs
+++ b/ghc/compiler/typecheck/TcTyDecls.lhs
@@ -36,7 +36,7 @@ import DataCon		( DataCon, dataConSig, mkDataCon, isNullaryDataCon,
 			)
 import MkId		( mkDataConId, mkRecordSelId, mkNewTySelId )
 import Id		( getIdUnfolding )
-import CoreUnfold	( getUnfoldingTemplate )
+import CoreUnfold	( unfoldingTemplate )
 import FieldLabel
 import Var		( Id, TyVar )
 import Name		( Name, isLocallyDefined, OccName, NamedThing(..), nameUnique )
@@ -277,7 +277,7 @@ mkDataBinds_one tycon
 	-- For the locally-defined things
 	-- we need to turn the unfoldings inside the Ids into bindings,
 	binds | isLocallyDefined tycon
-	      = [ CoreMonoBind data_id (getUnfoldingTemplate (getIdUnfolding data_id))
+	      = [ CoreMonoBind data_id (unfoldingTemplate (getIdUnfolding data_id))
 		| data_id <- data_ids, isLocallyDefined data_id
 		]
 	      | otherwise
diff --git a/ghc/compiler/utils/UniqFM.lhs b/ghc/compiler/utils/UniqFM.lhs
index 868d20ac26e36863ffd26bacaadbd18a77a7c7d2..81d4bee7ffd7f806fe3432e40e2b8f2c4c0818d0 100644
--- a/ghc/compiler/utils/UniqFM.lhs
+++ b/ghc/compiler/utils/UniqFM.lhs
@@ -51,6 +51,7 @@ import {-# SOURCE #-} Name	( Name )
 import Unique		( Uniquable(..), Unique, u2i, mkUniqueGrimily )
 import Panic
 import GlaExts		-- Lots of Int# operations
+import Outputable
 
 #if ! OMIT_NATIVE_CODEGEN
 #define IF_NCG(a) a
@@ -198,17 +199,15 @@ data UniqFM ele
 	    (UniqFM ele)
 	    (UniqFM ele)
 
--- for debugging only :-)
 {-
-instance Text (UniqFM a) where
-	showsPrec _ (NodeUFM a b t1 t2) =
-		  showString "NodeUFM " . shows (IBOX(a))
-		. showString " " . shows (IBOX(b))
-		. showString " (" . shows t1
-		. showString ") (" . shows t2
-		. showString ")"
-	showsPrec _ (LeafUFM x a) = showString "LeafUFM " . shows (IBOX(x))
-	showsPrec _ (EmptyUFM) = id
+-- for debugging only :-)
+instance Outputable (UniqFM a) where
+	ppr(NodeUFM a b t1 t2) =
+		sep [text "NodeUFM " <+> int IBOX(a) <+> int IBOX(b),
+		     nest 1 (parens (ppr t1)),
+		     nest 1 (parens (ppr t2))]
+	ppr (LeafUFM x a) = text "LeafUFM " <+> int IBOX(x)
+	ppr (EmptyUFM)    = empty
 -}
 \end{code}
 
diff --git a/ghc/driver/ghc.lprl b/ghc/driver/ghc.lprl
index fedb756a17405e1fef5b8052cdbf5ac7e72ff404..df3774962101d2ef370d4022ae21d0127a8b4701 100644
--- a/ghc/driver/ghc.lprl
+++ b/ghc/driver/ghc.lprl
@@ -713,65 +713,58 @@ sub setupOptimiseFlags {
 
 	'-fsimplify',
 	  '[', 
-	  '-finline-phase1',		# Don't inline rule Ids till specialisation has bitten
-
-#		APR 99: the stuff in this comment is now
-#		handled by -finline-phase1
-#
-# I don't understand why we want -fessential-unfoldings-only here
-# If we have it, the following nasty thing happens:
-#	f  = E
-#	g* = f
-#	...g...
-# where "*" means exported.
-# In the essential-unfoldings pass we still substitute f for g
-# but we don't substitute E for f first.  So we get
-#	f  = E
-#	g* = f
-#	...f...
-# The g=f will get reverse-substituted later, but it's untidy. --SLPJ
-#
-# SDM: Here's why it's necessary.
-#
-#   If we unfold in the first pass before the specialiser is run
-#   we miss opportunities for specialisation because eg. wrappers
-#   have been inlined for specialisable functions.  
-#
-#   This shows up in PrelArr.lhs - the specialised instance for newArray 
-#   calls the generic rangeSize, because rangeSize is strict and is
-#   replaced by its wrapper by the simplifier.
-#	  '-fessential-unfoldings-only',
-#	  '-fsimpl-uf-use-threshold0',
-
-	  '-fmax-simplifier-iterations2',
+		'-finline-phase0',	# Don't inline anything till full laziness has bitten
+					# In particular, inlining wrappers inhibits floating
+					# e.g. ...(case f x of ...)...
+					#  ==> ...(case (case x of I# x# -> fw x#) of ...)...
+					#  ==> ...(case x of I# x# -> case fw x# of ...)...
+					# and now the redex (f x) isn't floatable any more
+		'-fmax-simplifier-iterations2',
 	  ']',
 
+	# Specialisation is best done before full laziness
+	# so that overloaded functions have all their dictionary lambdas manifest
 	($Oopt_DoSpecialise) ? ( $Oopt_DoSpecialise, ) : (),
+	'-ffull-laziness',
+	'-ffloat-inwards',
+
+#	'-fsimplify',
+#	  '[', 
+#		# Run the simplifier before specialising, so that overloaded functions
+#		# look like 		f = \d -> ...
+#		# (Full laziness may lift out something hiding the \d
+#		'-finline-phase1',
+#		'-fmax-simplifier-iterations1',
+#	  ']',
 
-        $Oopt_UsageSPInf, # infer usage information here in case we need it later.
-                          # (add more of these where you need them --KSW 1999-04)
 
 	'-fsimplify',
 	  '[', 
-	  	$Oopt_MaxSimplifierIterations,	
-
-		# Still don't inline transformation rule Ids, to give the
-		# rules a good chance to fire
-		'-finline-phase1',
+	  	'-finline-phase1',
+		# Want to run with inline phase 1 after the specialiser to give
+		# maximum chance for fusion to work before we inline build/augment
+		# in phase 2.  This made a difference in 'ansi' where an overloaded
+		# function wasn't inlined till too late.
+		$Oopt_MaxSimplifierIterations,	
 	  ']',
 
-	'-ffull-laziness',
-
-	'-ffloat-inwards',
+        $Oopt_UsageSPInf, # infer usage information here in case we need it later.
+                          # (add more of these where you need them --KSW 1999-04)
 
 	'-fsimplify',
 	  '[', 
-	  	'-finline-phase2',
-		$Oopt_MaxSimplifierIterations,	
+		# Need inline-phase2 here so that build/augment get 
+		# inlined.  I found that spectral/hartel/genfft lost some useful
+		# strictness in the function sumcode' if augment is not inlined
+		# before strictness analysis runs
+
+		'-finline-phase2',
+	  	$Oopt_MaxSimplifierIterations,	
 	  ']',
 
+
 	'-fstrictness',
-	# '-fcpr-analyse',
+	'-fcpr-analyse',
 	'-fworker-wrapper',
 
 	'-fsimplify',
@@ -781,6 +774,7 @@ sub setupOptimiseFlags {
 	  ']',
 
 	'-ffloat-inwards',
+	'-fcse',
 
 # Case-liberation for -O2.  This should be after
 # strictness analysis and the simplification which follows it.
@@ -794,6 +788,7 @@ sub setupOptimiseFlags {
 	'-fsimplify',
 	  '[', 
 	  	$Oopt_MaxSimplifierIterations,	
+		# No -finline-phase: allow all Ids to be inlined now
 	  ']',
 
       #	'-fstatic-args',
@@ -3058,6 +3053,7 @@ arg: while($_ = $Args[0]) {
     /^-fallow-overlapping-instances$/ && do { push(@HsC_flags, $_); next arg; };
     /^-fallow-undecidable-instances$/ && do { push(@HsC_flags, $_); next arg; };
     /^-fhistory-size.*$/ 	      && do { push(@HsC_flags, $_); next arg; };
+    /^-fdicts-strict$/ 	  	      && do { push(@HsC_flags, $_); next arg; };
     /^-fglasgow-exts$/
 		&& do { push(@HsC_flags, $_);
 
diff --git a/ghc/lib/std/PrelBase.lhs b/ghc/lib/std/PrelBase.lhs
index 744f8a6fdc0c34b4dd405e80bf524754d0d2cdd7..e3d4d6f2284fddffb6231c6a399770bae0c21c2a 100644
--- a/ghc/lib/std/PrelBase.lhs
+++ b/ghc/lib/std/PrelBase.lhs
@@ -138,8 +138,13 @@ The rest of the prelude list functions are in PrelList.
   
 \begin{code}
 foldr            :: (a -> b -> b) -> b -> [a] -> b
-foldr _ z []     =  z
-foldr f z (x:xs) =  f x (foldr f z xs)
+-- foldr _ z []     =  z
+-- foldr f z (x:xs) =  f x (foldr f z xs)
+{-# INLINE foldr #-}
+foldr k z xs = go xs
+	     where
+	       go []     = z
+	       go (x:xs) = x `k` go xs
 
 build 	:: forall a. (forall b. (a -> b -> b) -> b -> b) -> [a]
 {-# INLINE build #-}
@@ -178,7 +183,8 @@ map :: (a -> b) -> [a] -> [b]
 {-# INLINE map #-}
 map f xs = build (\c n -> foldr (mapFB c f) n xs)
 
-mapFB c f xs = c (f xs)
+-- Note eta expanded
+mapFB c f x ys = c (f x) ys
 
 mapList :: (a -> b) -> [a] -> [b]
 mapList _ []     = []
@@ -284,7 +290,21 @@ data Ordering = LT | EQ | GT deriving (Eq, Ord)
 \begin{code}
 type  String = [Char]
 
-data Char = C# Char#	deriving (Eq, Ord)
+data Char = C# Char#
+
+-- We don't use deriving for Eq and Ord, because for Ord the derived
+-- instance defines only compare, which takes two primops.  Then
+-- '>' uses compare, and therefore takes two primops instead of one.
+
+instance Eq Char where
+  (C# c1) == (C# c2) = c1 `eqChar#` c2
+  (C# c1) /= (C# c2) = c1 `neChar#` c2
+
+instance Ord Char where
+  (C# c1) >  (C# c2) = c1 `gtChar#` c2
+  (C# c1) >= (C# c2) = c1 `geChar#` c2
+  (C# c1) <= (C# c2) = c1 `leChar#` c2
+  (C# c1) <  (C# c2) = c1 `ltChar#` c2
 
 chr :: Int -> Char
 chr (I# i) | i >=# 0# && i <=# 255# = C# (chr# i)
diff --git a/ghc/lib/std/PrelList.lhs b/ghc/lib/std/PrelList.lhs
index c8b89cafa8950d2d857b0cb728b7682b7427c54c..6983e85fd15af4aba8d366092f3bb629b9fd1271 100644
--- a/ghc/lib/std/PrelList.lhs
+++ b/ghc/lib/std/PrelList.lhs
@@ -51,7 +51,18 @@ infix  4 `elem`, `notElem`
 
 head                    :: [a] -> a
 head (x:_)              =  x
-head []                 =  errorEmptyList "head"
+head []                 =  badHead
+
+badHead = errorEmptyList "head"
+
+-- This rule is useful in cases like 
+--	head [y | (x,y) <- ps, x==t]
+{-# RULES
+"head/build"	forall g::forall b.(Bool->b->b)->b->b . 
+		head (build g) = g (\x _ -> x) badHead
+"head/augment"	forall xs, g::forall b. (a->b->b) -> b -> b . 
+		head (augment g xs) = g (\x _ -> x) (head xs)
+ #-}
 
 tail                    :: [a] -> [a]
 tail (_:xs)             =  xs
diff --git a/ghc/mk/version.mk b/ghc/mk/version.mk
index 5c62e6dc4d0888237aa1104dc0e502b47edd0824..bf2fe43930942108fe528d12c2babaacdeb83a07 100644
--- a/ghc/mk/version.mk
+++ b/ghc/mk/version.mk
@@ -47,3 +47,7 @@ CcMinorVersion=1
 # that will break compatibility with older versions, up this variable.
 # 
 HscIfaceFileVersion=5
+#	But watch out: interface file format after Simon's renamer
+#	hacking isn't the same as before, but it may not make
+#	any difference for the GHC boot files.
+#		May 1999