Merge remote-tracking branch 'origin/master' into tc-untouchables

52 files changed, 1044 insertions, 1553 deletions

diff --git a/compiler/basicTypes/Literal.lhs b/compiler/basicTypes/Literal.lhs
index 220ef9edd1..a590eae1b2 100644
--- a/compiler/basicTypes/Literal.lhs
+++ b/compiler/basicTypes/Literal.lhs
@@ -351,10 +351,9 @@ litIsDupable dflags (LitInteger i _) = inIntRange dflags i
 litIsDupable _      _                = True
 
 litFitsInChar :: Literal -> Bool
-litFitsInChar (MachInt i)
-                         = fromInteger i <= ord minBound
-                        && fromInteger i >= ord maxBound
-litFitsInChar _         = False
+litFitsInChar (MachInt i) = i >= toInteger (ord minBound)
+                         && i <= toInteger (ord maxBound)
+litFitsInChar _           = False
 
 litIsLifted :: Literal -> Bool
 litIsLifted (LitInteger {}) = True
diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs
index 1ff76c6fe4..a5d559e9ff 100644
--- a/compiler/cmm/CLabel.hs
+++ b/compiler/cmm/CLabel.hs
@@ -13,7 +13,7 @@ module CLabel (
 
         mkClosureLabel,
         mkSRTLabel,
-        mkModSRTLabel,
+        mkTopSRTLabel,
         mkInfoTableLabel,
         mkEntryLabel,
         mkSlowEntryLabel,
@@ -120,8 +120,6 @@ import DynFlags
 import Platform
 import UniqSet
 
-import Data.Maybe (isJust)
-
 -- -----------------------------------------------------------------------------
 -- The CLabel type
 
@@ -218,7 +216,7 @@ data CLabel
   | HpcTicksLabel Module
 
   -- | Static reference table
-  | SRTLabel (Maybe Module) !Unique
+  | SRTLabel !Unique
 
   -- | Label of an StgLargeSRT
   | LargeSRTLabel
@@ -355,8 +353,8 @@ data DynamicLinkerLabelInfo
 mkSlowEntryLabel :: Name -> CafInfo -> CLabel
 mkSlowEntryLabel        name c         = IdLabel name  c Slow
 
-mkModSRTLabel     :: Maybe Module -> Unique -> CLabel
-mkModSRTLabel mb_mod u = SRTLabel mb_mod u
+mkTopSRTLabel     :: Unique -> CLabel
+mkTopSRTLabel u = SRTLabel u
 
 mkSRTLabel        :: Name -> CafInfo -> CLabel
 mkRednCountsLabel :: Name -> CafInfo -> CLabel
@@ -592,7 +590,7 @@ needsCDecl :: CLabel -> Bool
   -- False <=> it's pre-declared; don't bother
   -- don't bother declaring Bitmap labels, we always make sure
   -- they are defined before use.
-needsCDecl (SRTLabel _ _)               = True
+needsCDecl (SRTLabel _)                 = True
 needsCDecl (LargeSRTLabel _)            = False
 needsCDecl (LargeBitmapLabel _)         = False
 needsCDecl (IdLabel _ _ _)              = True
@@ -740,7 +738,7 @@ externallyVisibleCLabel (CCS_Label _)           = True
 externallyVisibleCLabel (DynamicLinkerLabel _ _)  = False
 externallyVisibleCLabel (HpcTicksLabel _)       = True
 externallyVisibleCLabel (LargeBitmapLabel _)    = False
-externallyVisibleCLabel (SRTLabel mb_mod _)     = isJust mb_mod
+externallyVisibleCLabel (SRTLabel _)            = False
 externallyVisibleCLabel (LargeSRTLabel _)       = False
 externallyVisibleCLabel (PicBaseLabel {}) = panic "externallyVisibleCLabel PicBaseLabel"
 externallyVisibleCLabel (DeadStripPreventer {}) = panic "externallyVisibleCLabel DeadStripPreventer"
@@ -788,7 +786,7 @@ labelType (RtsLabel (RtsApFast _))              = CodeLabel
 labelType (CaseLabel _ CaseReturnInfo)          = DataLabel
 labelType (CaseLabel _ _)                       = CodeLabel
 labelType (PlainModuleInitLabel _)              = CodeLabel
-labelType (SRTLabel _ _)                        = DataLabel
+labelType (SRTLabel _)                          = DataLabel
 labelType (LargeSRTLabel _)                     = DataLabel
 labelType (LargeBitmapLabel _)                  = DataLabel
 labelType (ForeignLabel _ _ _ IsFunction)       = CodeLabel
@@ -991,10 +989,8 @@ pprCLbl (CaseLabel u (CaseAlt tag))
 pprCLbl (CaseLabel u CaseDefault)
   = hcat [pprUnique u, ptext (sLit "_dflt")]
 
-pprCLbl (SRTLabel mb_mod u)
-  = pp_mod <> pprUnique u <> pp_cSEP <> ptext (sLit "srt")
-  where pp_mod | Just mod <- mb_mod = ppr mod <> pp_cSEP
-               | otherwise          = empty
+pprCLbl (SRTLabel u)
+  = pprUnique u <> pp_cSEP <> ptext (sLit "srt")
 
 pprCLbl (LargeSRTLabel u)  = pprUnique u <> pp_cSEP <> ptext (sLit "srtd")
 pprCLbl (LargeBitmapLabel u)  = text "b" <> pprUnique u <> pp_cSEP <> ptext (sLit "btm")
diff --git a/compiler/cmm/CmmBuildInfoTables.hs b/compiler/cmm/CmmBuildInfoTables.hs
index d587d60f95..ecaab57d76 100644
--- a/compiler/cmm/CmmBuildInfoTables.hs
+++ b/compiler/cmm/CmmBuildInfoTables.hs
@@ -14,28 +14,23 @@
 {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
 module CmmBuildInfoTables
     ( CAFSet, CAFEnv, cafAnal
-    , doSRTs, TopSRT, emptySRT, srtToData )
+    , doSRTs, TopSRT, emptySRT, isEmptySRT, srtToData )
 where
 
 #include "HsVersions.h"
 
--- These should not be imported here!
-import StgCmmUtils
 import Hoopl
-
 import Digraph
-import qualified Prelude as P
-import Prelude hiding (succ)
-
 import BlockId
 import Bitmap
 import CLabel
+import PprCmmDecl ()
 import Cmm
 import CmmUtils
+import CmmInfo
 import Data.List
 import DynFlags
 import Maybes
-import Module
 import Outputable
 import SMRep
 import UniqSupply
@@ -47,6 +42,9 @@ import Data.Set (Set)
 import qualified Data.Set as Set
 import Control.Monad
 
+import qualified Prelude as P
+import Prelude hiding (succ)
+
 foldSet :: (a -> b -> b) -> b -> Set a -> b
 foldSet = Set.foldr
 
@@ -137,11 +135,14 @@ instance Outputable TopSRT where
                    <+> ppr elts
                    <+> ppr eltmap
 
-emptySRT :: MonadUnique m => Maybe Module -> m TopSRT
-emptySRT mb_mod =
-  do top_lbl <- getUniqueM >>= \ u -> return $ mkModSRTLabel mb_mod u
+emptySRT :: MonadUnique m => m TopSRT
+emptySRT =
+  do top_lbl <- getUniqueM >>= \ u -> return $ mkTopSRTLabel u
      return TopSRT { lbl = top_lbl, next_elt = 0, rev_elts = [], elt_map = Map.empty }
 
+isEmptySRT :: TopSRT -> Bool
+isEmptySRT srt = null (rev_elts srt)
+
 cafMember :: TopSRT -> CLabel -> Bool
 cafMember srt lbl = Map.member lbl (elt_map srt)
 
@@ -228,7 +229,7 @@ maxBmpSize dflags = widthInBits (wordWidth dflags) `div` 2
 -- Adapted from codeGen/StgCmmUtils, which converts from SRT to C_SRT.
 to_SRT :: DynFlags -> CLabel -> Int -> Int -> Bitmap -> UniqSM (Maybe CmmDecl, C_SRT)
 to_SRT dflags top_srt off len bmp
-  | len > maxBmpSize dflags || bmp == [toStgWord dflags (fromStgHalfWord (srt_escape dflags))]
+  | len > maxBmpSize dflags || bmp == [toStgWord dflags (fromStgHalfWord (srtEscape dflags))]
   = do id <- getUniqueM
        let srt_desc_lbl = mkLargeSRTLabel id
            tbl = CmmData RelocatableReadOnlyData $
@@ -236,7 +237,7 @@ to_SRT dflags top_srt off len bmp
                      ( cmmLabelOffW dflags top_srt off
                      : mkWordCLit dflags (toStgWord dflags (fromIntegral len))
                      : map (mkWordCLit dflags) bmp)
-       return (Just tbl, C_SRT srt_desc_lbl 0 (srt_escape dflags))
+       return (Just tbl, C_SRT srt_desc_lbl 0 (srtEscape dflags))
   | otherwise
   = return (Nothing, C_SRT top_srt off (toStgHalfWord dflags (fromStgWord (head bmp))))
 	-- The fromIntegral converts to StgHalfWord
diff --git a/compiler/cmm/CmmInfo.hs b/compiler/cmm/CmmInfo.hs
index 9d335c6f7b..6aa4d6cbfa 100644
--- a/compiler/cmm/CmmInfo.hs
+++ b/compiler/cmm/CmmInfo.hs
@@ -9,6 +9,7 @@ module CmmInfo (
   mkEmptyContInfoTable,
   cmmToRawCmm,
   mkInfoTable,
+  srtEscape
 ) where
 
 #include "HsVersions.h"
@@ -384,3 +385,9 @@ newStringLit bytes
   = do { uniq <- getUniqueUs
        ; return (mkByteStringCLit uniq bytes) }
 
+
+-- Misc utils
+
+-- | Value of the srt field of an info table when using an StgLargeSRT
+srtEscape :: DynFlags -> StgHalfWord
+srtEscape dflags = toStgHalfWord dflags (-1)
diff --git a/compiler/cmm/CmmLayoutStack.hs b/compiler/cmm/CmmLayoutStack.hs
index 5505b92f5a..6f75f5451c 100644
--- a/compiler/cmm/CmmLayoutStack.hs
+++ b/compiler/cmm/CmmLayoutStack.hs
@@ -3,8 +3,9 @@ module CmmLayoutStack (
        cmmLayoutStack, setInfoTableStackMap
   ) where
 
-import StgCmmUtils      ( callerSaveVolatileRegs ) -- XXX
-import StgCmmForeign    ( saveThreadState, loadThreadState ) -- XXX
+import StgCmmUtils      ( callerSaveVolatileRegs ) -- XXX layering violation
+import StgCmmForeign    ( saveThreadState, loadThreadState ) -- XXX layering violation
+import StgCmmLayout     ( entryCode ) -- XXX layering violation
 
 import Cmm
 import BlockId
@@ -939,7 +940,8 @@ lowerSafeForeignCall dflags block
         -- received an exception during the call, then the stack might be
         -- different.  Hence we continue by jumping to the top stack frame,
         -- not by jumping to succ.
-        jump = CmmCall { cml_target    = CmmLoad (CmmReg spReg) (bWord dflags)
+        jump = CmmCall { cml_target    = entryCode dflags $
+                                         CmmLoad (CmmReg spReg) (bWord dflags)
                        , cml_cont      = Just succ
                        , cml_args_regs = regs
                        , cml_args      = widthInBytes (wordWidth dflags)
diff --git a/compiler/cmm/CmmOpt.hs b/compiler/cmm/CmmOpt.hs
index 0df24a6a66..32afa1d078 100644
--- a/compiler/cmm/CmmOpt.hs
+++ b/compiler/cmm/CmmOpt.hs
@@ -7,8 +7,6 @@
 -----------------------------------------------------------------------------
 
 module CmmOpt (
-        cmmEliminateDeadBlocks,
-        cmmMiniInline,
         cmmMachOpFold,
         cmmMachOpFoldM,
         cmmLoopifyForC,
@@ -17,282 +15,15 @@ module CmmOpt (
 #include "HsVersions.h"
 
 import OldCmm
-import OldPprCmm
-import CmmNode (wrapRecExp)
-import CmmUtils
 import DynFlags
 import CLabel
 
-import UniqFM
-import Unique
-import Util
 import FastTypes
 import Outputable
 import Platform
-import BlockId
 
 import Data.Bits
 import Data.Maybe
-import Data.List
-
--- -----------------------------------------------------------------------------
--- Eliminates dead blocks
-
-{-
-We repeatedly expand the set of reachable blocks until we hit a
-fixpoint, and then prune any blocks that were not in this set.  This is
-actually a required optimization, as dead blocks can cause problems
-for invariants in the linear register allocator (and possibly other
-places.)
--}
-
--- Deep fold over statements could probably be abstracted out, but it
--- might not be worth the effort since OldCmm is moribund
-cmmEliminateDeadBlocks :: [CmmBasicBlock] -> [CmmBasicBlock]
-cmmEliminateDeadBlocks [] = []
-cmmEliminateDeadBlocks blocks@(BasicBlock base_id _:_) =
-    let -- Calculate what's reachable from what block
-        reachableMap = foldl' f emptyUFM blocks -- lazy in values
-            where f m (BasicBlock block_id stmts) = addToUFM m block_id (reachableFrom stmts)
-        reachableFrom stmts = foldl stmt [] stmts
-            where
-                stmt m CmmNop = m
-                stmt m (CmmComment _) = m
-                stmt m (CmmAssign _ e) = expr m e
-                stmt m (CmmStore e1 e2) = expr (expr m e1) e2
-                stmt m (CmmCall c _ as _) = f (actuals m as) c
-                    where f m (CmmCallee e _) = expr m e
-                          f m (CmmPrim _ Nothing) = m
-                          f m (CmmPrim _ (Just stmts)) = foldl' stmt m stmts
-                stmt m (CmmBranch b) = b:m
-                stmt m (CmmCondBranch e b) = b:(expr m e)
-                stmt m (CmmSwitch e bs) = catMaybes bs ++ expr m e
-                stmt m (CmmJump e _) = expr m e
-                stmt m (CmmReturn) = m
-                actuals m as = foldl' (\m h -> expr m (hintlessCmm h)) m as
-                -- We have to do a deep fold into CmmExpr because
-                -- there may be a BlockId in the CmmBlock literal.
-                expr m (CmmLit l) = lit m l
-                expr m (CmmLoad e _) = expr m e
-                expr m (CmmReg _) = m
-                expr m (CmmMachOp _ es) = foldl' expr m es
-                expr m (CmmStackSlot _ _) = m
-                expr m (CmmRegOff _ _) = m
-                lit m (CmmBlock b) = b:m
-                lit m _ = m
-        -- go todo done
-        reachable = go [base_id] (setEmpty :: BlockSet)
-          where go []     m = m
-                go (x:xs) m
-                    | setMember x m = go xs m
-                    | otherwise     = go (add ++ xs) (setInsert x m)
-                        where add = fromMaybe (panic "cmmEliminateDeadBlocks: unknown block")
-                                              (lookupUFM reachableMap x)
-    in filter (\(BasicBlock block_id _) -> setMember block_id reachable) blocks
-
--- -----------------------------------------------------------------------------
--- The mini-inliner
-
-{-
-This pass inlines assignments to temporaries.  Temporaries that are
-only used once are unconditionally inlined.  Temporaries that are used
-two or more times are only inlined if they are assigned a literal.  It
-works as follows:
-
-  - count uses of each temporary
-  - for each temporary:
-        - attempt to push it forward to the statement that uses it
-        - only push forward past assignments to other temporaries
-          (assumes that temporaries are single-assignment)
-        - if we reach the statement that uses it, inline the rhs
-          and delete the original assignment.
-
-[N.B. In the Quick C-- compiler, this optimization is achieved by a
- combination of two dataflow passes: forward substitution (peephole
- optimization) and dead-assignment elimination.  ---NR]
-
-Possible generalisations: here is an example from factorial
-
-Fac_zdwfac_entry:
-    cmG:
-        _smi = R2;
-        if (_smi != 0) goto cmK;
-        R1 = R3;
-        jump I64[Sp];
-    cmK:
-        _smn = _smi * R3;
-        R2 = _smi + (-1);
-        R3 = _smn;
-        jump Fac_zdwfac_info;
-
-We want to inline _smi and _smn.  To inline _smn:
-
-   - we must be able to push forward past assignments to global regs.
-     We can do this if the rhs of the assignment we are pushing
-     forward doesn't refer to the global reg being assigned to; easy
-     to test.
-
-To inline _smi:
-
-   - It is a trivial replacement, reg for reg, but it occurs more than
-     once.
-   - We can inline trivial assignments even if the temporary occurs
-     more than once, as long as we don't eliminate the original assignment
-     (this doesn't help much on its own).
-   - We need to be able to propagate the assignment forward through jumps;
-     if we did this, we would find that it can be inlined safely in all
-     its occurrences.
--}
-
-countUses :: UserOfLocalRegs a => a -> UniqFM Int
-countUses a = foldRegsUsed (\m r -> addToUFM_C (+) m r 1) emptyUFM a
-
-cmmMiniInline :: DynFlags -> [CmmBasicBlock] -> [CmmBasicBlock]
-cmmMiniInline dflags blocks = map do_inline blocks
-  where do_inline (BasicBlock id stmts)
-          = BasicBlock id (cmmMiniInlineStmts dflags (countUses blocks) stmts)
-
-cmmMiniInlineStmts :: DynFlags -> UniqFM Int -> [CmmStmt] -> [CmmStmt]
-cmmMiniInlineStmts _      _    [] = []
-cmmMiniInlineStmts dflags uses (stmt@(CmmAssign (CmmLocal (LocalReg u _)) expr) : stmts)
-        -- not used: just discard this assignment
-  | 0 <- lookupWithDefaultUFM uses 0 u
-  = cmmMiniInlineStmts dflags uses stmts
-
-        -- used (foldable to small thing): try to inline at all the use sites
-  | Just n <- lookupUFM uses u,
-    e <- wrapRecExp foldExp expr,
-    isTiny e
-  =
-     ncgDebugTrace ("nativeGen: inlining " ++ showSDoc dflags (pprStmt stmt)) $
-     case lookForInlineMany u e stmts of
-         (m, stmts')
-             | n == m -> cmmMiniInlineStmts dflags (delFromUFM uses u) stmts'
-             | otherwise ->
-                 stmt : cmmMiniInlineStmts dflags (adjustUFM (\x -> x - m) uses u) stmts'
-
-        -- used once (non-literal): try to inline at the use site
-  | Just 1 <- lookupUFM uses u,
-    Just stmts' <- lookForInline u expr stmts
-  = 
-     ncgDebugTrace ("nativeGen: inlining " ++ showSDoc dflags (pprStmt stmt)) $
-     cmmMiniInlineStmts dflags uses stmts'
- where
-  isTiny (CmmLit _) = True
-  isTiny (CmmReg (CmmGlobal _)) = True
-         -- not CmmLocal: that might invalidate the usage analysis results
-  isTiny _ = False
-
-  foldExp (CmmMachOp op args) = cmmMachOpFold dflags op args
-  foldExp e = e
-
-  ncgDebugTrace str x = if ncgDebugIsOn then trace str x else x
-
-cmmMiniInlineStmts platform uses (stmt:stmts)
-  = stmt : cmmMiniInlineStmts platform uses stmts
-
--- | Takes a register, a 'CmmLit' expression assigned to that
--- register, and a list of statements.  Inlines the expression at all
--- use sites of the register.  Returns the number of substituations
--- made and the, possibly modified, list of statements.
-lookForInlineMany :: Unique -> CmmExpr -> [CmmStmt] -> (Int, [CmmStmt])
-lookForInlineMany u expr stmts = lookForInlineMany' u expr regset stmts
-    where regset = foldRegsUsed extendRegSet emptyRegSet expr
-
-lookForInlineMany' :: Unique -> CmmExpr -> RegSet -> [CmmStmt] -> (Int, [CmmStmt])
-lookForInlineMany' _ _ _ [] = (0, [])
-lookForInlineMany' u expr regset stmts@(stmt : rest)
-  | Just n <- lookupUFM (countUses stmt) u, okToInline expr stmt
-  = let stmt' = inlineStmt u expr stmt in
-    if okToSkip stmt' u expr regset
-       then case lookForInlineMany' u expr regset rest of
-                       (m, stmts) -> let z = n + m
-                                     in z `seq` (z, stmt' : stmts)
-       else (n, stmt' : rest)
-
-  | okToSkip stmt u expr regset
-  = case lookForInlineMany' u expr regset rest of
-      (n, stmts) -> (n, stmt : stmts)
-
-  | otherwise
-  = (0, stmts)
-
-
-lookForInline :: Unique -> CmmExpr -> [CmmStmt] -> Maybe [CmmStmt]
-lookForInline u expr stmts = lookForInline' u expr regset stmts
-    where regset = foldRegsUsed extendRegSet emptyRegSet expr
-
-lookForInline' :: Unique -> CmmExpr -> RegSet -> [CmmStmt] -> Maybe [CmmStmt]
-lookForInline' _ _    _      [] = panic "lookForInline' []"
-lookForInline' u expr regset (stmt : rest)
-  | Just 1 <- lookupUFM (countUses stmt) u, okToInline expr stmt
-  = Just (inlineStmt u expr stmt : rest)
-
-  | okToSkip stmt u expr regset
-  = case lookForInline' u expr regset rest of
-           Nothing    -> Nothing
-           Just stmts -> Just (stmt:stmts)
-
-  | otherwise 
-  = Nothing
-
-
--- we don't inline into CmmCall if the expression refers to global
--- registers.  This is a HACK to avoid global registers clashing with
--- C argument-passing registers, really the back-end ought to be able
--- to handle it properly, but currently neither PprC nor the NCG can
--- do it.  See also CgForeignCall:load_args_into_temps.
-okToInline :: CmmExpr -> CmmStmt -> Bool
-okToInline expr CmmCall{} = hasNoGlobalRegs expr
-okToInline _ _ = True
-
--- Expressions aren't side-effecting.  Temporaries may or may not
--- be single-assignment depending on the source (the old code
--- generator creates single-assignment code, but hand-written Cmm
--- and Cmm from the new code generator is not single-assignment.)
--- So we do an extra check to make sure that the register being
--- changed is not one we were relying on.  I don't know how much of a
--- performance hit this is (we have to create a regset for every
--- instruction.) -- EZY
-okToSkip :: CmmStmt -> Unique -> CmmExpr -> RegSet -> Bool
-okToSkip stmt u expr regset
-   = case stmt of
-         CmmNop -> True
-         CmmComment{} -> True
-         CmmAssign (CmmLocal r@(LocalReg u' _)) _rhs | u' /= u && not (r `elemRegSet` regset) -> True
-         CmmAssign g@(CmmGlobal _) _rhs -> not (g `regUsedIn` expr)
-         CmmStore _ _ -> not_a_load expr
-         _other -> False
-  where
-    not_a_load (CmmMachOp _ args) = all not_a_load args
-    not_a_load (CmmLoad _ _) = False
-    not_a_load _ = True
-
-inlineStmt :: Unique -> CmmExpr -> CmmStmt -> CmmStmt
-inlineStmt u a (CmmAssign r e) = CmmAssign r (inlineExpr u a e)
-inlineStmt u a (CmmStore e1 e2) = CmmStore (inlineExpr u a e1) (inlineExpr u a e2)
-inlineStmt u a (CmmCall target regs es ret)
-   = CmmCall (infn target) regs es' ret
-   where infn (CmmCallee fn cconv) = CmmCallee (inlineExpr u a fn) cconv
-         infn (CmmPrim p mStmts) = CmmPrim p (fmap (map (inlineStmt u a)) mStmts)
-         es' = [ (CmmHinted (inlineExpr u a e) hint) | (CmmHinted e hint) <- es ]
-inlineStmt u a (CmmCondBranch e d) = CmmCondBranch (inlineExpr u a e) d
-inlineStmt u a (CmmSwitch e d) = CmmSwitch (inlineExpr u a e) d
-inlineStmt u a (CmmJump e live) = CmmJump (inlineExpr u a e) live
-inlineStmt _ _ other_stmt = other_stmt
-
-inlineExpr :: Unique -> CmmExpr -> CmmExpr -> CmmExpr
-inlineExpr u a e@(CmmReg (CmmLocal (LocalReg u' _)))
-  | u == u' = a
-  | otherwise = e
-inlineExpr u a e@(CmmRegOff (CmmLocal (LocalReg u' rep)) off)
-  | u == u' = CmmMachOp (MO_Add width) [a, CmmLit (CmmInt (fromIntegral off) width)]
-  | otherwise = e
-  where
-    width = typeWidth rep
-inlineExpr u a (CmmLoad e rep) = CmmLoad (inlineExpr u a e) rep
-inlineExpr u a (CmmMachOp op es) = CmmMachOp op (map (inlineExpr u a) es)
-inlineExpr _ _ other_expr = other_expr
 
 -- -----------------------------------------------------------------------------
 -- MachOp constant folder
diff --git a/compiler/cmm/CmmPipeline.hs b/compiler/cmm/CmmPipeline.hs
index 25fda1ca07..5fca9e7164 100644
--- a/compiler/cmm/CmmPipeline.hs
+++ b/compiler/cmm/CmmPipeline.hs
@@ -114,7 +114,8 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}})
                              procPointAnalysis proc_points g
             dumpWith dflags Opt_D_dump_cmmz_procmap "procpoint map" pp_map
             gs <- {-# SCC "splitAtProcPoints" #-} runUniqSM $
-                  splitAtProcPoints l call_pps proc_points pp_map (CmmProc h l g)
+                  splitAtProcPoints dflags l call_pps proc_points pp_map
+                                    (CmmProc h l g)
             dumps Opt_D_dump_cmmz_split "Post splitting" gs
      
             ------------- Populate info tables with stack info -----------------
diff --git a/compiler/cmm/CmmProcPoint.hs b/compiler/cmm/CmmProcPoint.hs
index 58f2e54ffa..471faf8b0c 100644
--- a/compiler/cmm/CmmProcPoint.hs
+++ b/compiler/cmm/CmmProcPoint.hs
@@ -11,6 +11,7 @@ where
 
 import Prelude hiding (last, unzip, succ, zip)
 
+import DynFlags
 import BlockId
 import CLabel
 import Cmm
@@ -26,8 +27,6 @@ import UniqSupply
 
 import Hoopl
 
-import qualified Data.Map as Map
-
 -- Compute a minimal set of proc points for a control-flow graph.
 
 -- Determine a protocol for each proc point (which live variables will
@@ -207,9 +206,9 @@ extendPPSet platform g blocks procPoints =
 -- Input invariant: A block should only be reachable from a single ProcPoint.
 -- ToDo: use the _ret naming convention that the old code generator
 -- used. -- EZY
-splitAtProcPoints :: CLabel -> ProcPointSet-> ProcPointSet -> BlockEnv Status ->
+splitAtProcPoints :: DynFlags -> CLabel -> ProcPointSet-> ProcPointSet -> BlockEnv Status ->
                      CmmDecl -> UniqSM [CmmDecl]
-splitAtProcPoints entry_label callPPs procPoints procMap
+splitAtProcPoints dflags entry_label callPPs procPoints procMap
                   (CmmProc (TopInfo {info_tbls = info_tbls})
                            top_l g@(CmmGraph {g_entry=entry})) =
   do -- Build a map from procpoints to the blocks they reach
@@ -234,12 +233,15 @@ splitAtProcPoints entry_label callPPs procPoints procMap
      --  * Labels for the info tables of their new procedures (only if
      --    the proc point is a callPP)
      -- Due to common blockification, we may overestimate the set of procpoints.
-     let add_label map pp = Map.insert pp lbls map
+     let add_label map pp = mapInsert pp lbls map
            where lbls | pp == entry = (entry_label, Just (toInfoLbl entry_label))
                       | otherwise   = (blockLbl pp, guard (setMember pp callPPs) >> 
                                                     Just (infoTblLbl pp))
-         procLabels = foldl add_label Map.empty
+
+         procLabels :: LabelMap (CLabel, Maybe CLabel)
+         procLabels = foldl add_label mapEmpty
                             (filter (flip mapMember (toBlockMap g)) (setElems procPoints))
+
      -- In each new graph, add blocks jumping off to the new procedures,
      -- and replace branches to procpoints with branches to the jump-off blocks
      let add_jump_block (env, bs) (pp, l) =
@@ -259,8 +261,17 @@ splitAtProcPoints entry_label callPPs procPoints procMap
                       CmmCondBranch _ ti fi -> add_if_pp ti (add_if_pp fi rst)
                       CmmSwitch _ tbl       -> foldr add_if_pp rst (catMaybes tbl)
                       _                     -> rst
-                  add_if_pp id rst = case Map.lookup id procLabels of
-                                       Just (lbl, mb_info_lbl) -> (id, mb_info_lbl `orElse` lbl) : rst
+
+                  -- when jumping to a PP that has an info table, if
+                  -- tablesNextToCode is off we must jump to the entry
+                  -- label instead.
+                  jump_label (Just info_lbl) _
+                             | tablesNextToCode dflags = info_lbl
+                             | otherwise               = toEntryLbl info_lbl
+                  jump_label Nothing         block_lbl = block_lbl
+
+                  add_if_pp id rst = case mapLookup id procLabels of
+                                       Just (lbl, mb_info_lbl) -> (id, jump_label mb_info_lbl lbl) : rst
                                        Nothing                 -> rst
               (jumpEnv, jumpBlocks) <-
                  foldM add_jump_block (mapEmpty, []) needed_jumps
@@ -274,8 +285,10 @@ splitAtProcPoints entry_label callPPs procPoints procMap
               let g' = ofBlockMap ppId blockEnv'''
               -- pprTrace "g' pre jumps" (ppr g') $ do
               return (mapInsert ppId g' newGraphEnv)
+
      graphEnv <- foldM add_jumps emptyBlockMap $ mapToList graphEnv
-     let to_proc (bid, g) = case expectJust "pp label" $ Map.lookup bid procLabels of
+
+     let to_proc (bid, g) = case expectJust "pp label" $ mapLookup bid procLabels of
              (lbl, Just info_lbl)
                | bid == entry
                -> CmmProc (TopInfo {info_tbls=info_tbls, stack_info=stack_info})
@@ -295,7 +308,7 @@ splitAtProcPoints entry_label callPPs procPoints procMap
          replacePPIds g = {-# SCC "replacePPIds" #-}
                           mapGraphNodes (id, mapExp repl, mapExp repl) g
            where repl e@(CmmLit (CmmBlock bid)) =
-                   case Map.lookup bid procLabels of
+                   case mapLookup bid procLabels of
                      Just (_, Just info_lbl)  -> CmmLit (CmmLabel info_lbl)
                      _ -> e
                  repl e = e
@@ -312,7 +325,7 @@ splitAtProcPoints entry_label callPPs procPoints procMap
      return -- pprTrace "procLabels" (ppr procLabels)
             -- pprTrace "splitting graphs" (ppr procs)
             procs
-splitAtProcPoints _ _ _ _ t@(CmmData _ _) = return [t]
+splitAtProcPoints _ _ _ _ _ t@(CmmData _ _) = return [t]
 
 
 -- Only called from CmmProcPoint.splitAtProcPoints. NB. does a
diff --git a/compiler/cmm/CmmRewriteAssignments.hs b/compiler/cmm/CmmRewriteAssignments.hs
index 585d78e95b..0f2aeaa939 100644
--- a/compiler/cmm/CmmRewriteAssignments.hs
+++ b/compiler/cmm/CmmRewriteAssignments.hs
@@ -15,10 +15,11 @@ module CmmRewriteAssignments
   ( rewriteAssignments
   ) where
 
+import StgCmmUtils -- XXX layering violation
+
 import Cmm
 import CmmUtils
 import CmmOpt
-import StgCmmUtils
 
 import DynFlags
 import UniqSupply
diff --git a/compiler/cmm/CmmSink.hs b/compiler/cmm/CmmSink.hs
index 8c5c99d469..7acc4dd460 100644
--- a/compiler/cmm/CmmSink.hs
+++ b/compiler/cmm/CmmSink.hs
@@ -3,7 +3,7 @@ module CmmSink (
      cmmSink
   ) where
 
-import StgCmmUtils (callerSaves)
+import CodeGen.Platform (callerSaves)
 
 import Cmm
 import BlockId
@@ -155,7 +155,7 @@ cmmSink dflags graph = ofBlockList (g_entry graph) $ sink mapEmpty $ blocks
       drop_if a@(r,rhs,_) live_sets = (should_drop, live_sets')
           where
             should_drop =  conflicts dflags a final_last
-                        || {- not (isTiny rhs) && -} live_in_multi live_sets r
+                        || {- not (isSmall rhs) && -} live_in_multi live_sets r
                         || r `Set.member` live_in_joins
 
             live_sets' | should_drop = live_sets
@@ -172,12 +172,21 @@ cmmSink dflags graph = ofBlockList (g_entry graph) $ sink mapEmpty $ blocks
                  mapFromList [ (l, filterAssignments dflags (getLive l) assigs'')
                              | l <- succs ]
 
-{-
--- tiny: an expression we don't mind duplicating
-isTiny :: CmmExpr -> Bool
-isTiny (CmmReg _) = True
-isTiny (CmmLit _) = True
-isTiny _other     = False
+{- TODO: enable this later, when we have some good tests in place to
+   measure the effect and tune it.
+
+-- small: an expression we don't mind duplicating
+isSmall :: CmmExpr -> Bool
+isSmall (CmmReg (CmmLocal _)) = True  -- not globals, we want to coalesce them instead
+isSmall (CmmLit _) = True
+isSmall (CmmMachOp (MO_Add _) [x,y]) = isTrivial x && isTrivial y
+isSmall (CmmRegOff (CmmLocal _) _) = True
+isSmall _ = False
+
+isTrivial :: CmmExpr -> Bool
+isTrivial (CmmReg (CmmLocal _)) = True
+isTrivial (CmmLit _) = True
+isTrivial _ = False
 -}
 
 --
diff --git a/compiler/cmm/CmmType.hs b/compiler/cmm/CmmType.hs
index b6deb01bcd..d6da5a4022 100644
--- a/compiler/cmm/CmmType.hs
+++ b/compiler/cmm/CmmType.hs
@@ -12,6 +12,9 @@ module CmmType
     , wordWidth, halfWordWidth, cIntWidth, cLongWidth
     , halfWordMask
     , narrowU, narrowS
+    , rEP_CostCentreStack_mem_alloc
+    , rEP_CostCentreStack_scc_count
+    , rEP_StgEntCounter_allocs
    )
 where
 
@@ -239,6 +242,26 @@ narrowS W64 x = fromIntegral (fromIntegral x :: Int64)
 narrowS _ _ = panic "narrowTo"
 
 -------------------------------------------------------------------------
+
+-- These don't really belong here, but I don't know where is best to
+-- put them.
+
+rEP_CostCentreStack_mem_alloc :: DynFlags -> CmmType
+rEP_CostCentreStack_mem_alloc dflags
+    = cmmBits (widthFromBytes (pc_REP_CostCentreStack_mem_alloc pc))
+    where pc = sPlatformConstants (settings dflags)
+
+rEP_CostCentreStack_scc_count :: DynFlags -> CmmType
+rEP_CostCentreStack_scc_count dflags
+    = cmmBits (widthFromBytes (pc_REP_CostCentreStack_scc_count pc))
+    where pc = sPlatformConstants (settings dflags)
+
+rEP_StgEntCounter_allocs :: DynFlags -> CmmType
+rEP_StgEntCounter_allocs dflags
+    = cmmBits (widthFromBytes (pc_REP_StgEntCounter_allocs pc))
+    where pc = sPlatformConstants (settings dflags)
+
+-------------------------------------------------------------------------
 {-      Note [Signed vs unsigned]
         ~~~~~~~~~~~~~~~~~~~~~~~~~
 Should a CmmType include a signed vs. unsigned distinction?
diff --git a/compiler/cmm/MkGraph.hs b/compiler/cmm/MkGraph.hs
index 3233dbed8c..4ba82cd8f8 100644
--- a/compiler/cmm/MkGraph.hs
+++ b/compiler/cmm/MkGraph.hs
@@ -11,7 +11,7 @@ module MkGraph
   , mkJumpReturnsTo
   , mkJump, mkDirectJump, mkForeignJump, mkForeignJumpExtra, mkJumpGC
   , mkCbranch, mkSwitch
-  , mkReturn, mkReturnSimple, mkComment, mkCallEntry, mkBranch
+  , mkReturn, mkComment, mkCallEntry, mkBranch
   , copyInOflow, copyOutOflow
   , noExtraStack
   , toCall, Transfer(..)
@@ -69,34 +69,38 @@ flattenCmmAGraph id stmts =
     CmmGraph { g_entry = id,
                g_graph = GMany NothingO body NothingO }
   where
-  blocks = flatten1 (fromOL stmts) (blockJoinHead (CmmEntry id) emptyBlock) []
-  body = foldr addBlock emptyBody blocks
+  body = foldr addBlock emptyBody $ flatten id stmts []
 
   --
-  -- flatten: turn a list of CgStmt into a list of Blocks.  We know
-  -- that any code before the first label is unreachable, so just drop
-  -- it.
+  -- flatten: given an entry label and a CmmAGraph, make a list of blocks.
   --
   -- NB. avoid the quadratic-append trap by passing in the tail of the
   -- list.  This is important for Very Long Functions (e.g. in T783).
   --
-  flatten :: [CgStmt] -> [Block CmmNode C C] -> [Block CmmNode C C]
-  flatten [] blocks = blocks
+  flatten :: Label -> CmmAGraph -> [Block CmmNode C C] -> [Block CmmNode C C]
+  flatten id g blocks
+      = flatten1 (fromOL g) (blockJoinHead (CmmEntry id) emptyBlock) blocks
 
-  flatten (CgLabel id : stmts) blocks
+  --
+  -- flatten0: we are outside a block at this point: any code before
+  -- the first label is unreachable, so just drop it.
+  --
+  flatten0 :: [CgStmt] -> [Block CmmNode C C] -> [Block CmmNode C C]
+  flatten0 [] blocks = blocks
+
+  flatten0 (CgLabel id : stmts) blocks
     = flatten1 stmts block blocks
     where !block = blockJoinHead (CmmEntry id) emptyBlock
 
-  flatten (CgFork fork_id stmts : rest) blocks
-    = flatten1 (fromOL stmts) (blockJoinHead (CmmEntry fork_id) emptyBlock) $
-      flatten rest blocks
+  flatten0 (CgFork fork_id stmts : rest) blocks
+    = flatten fork_id stmts $ flatten0 rest blocks
 
-  flatten (CgLast _ : stmts) blocks = flatten stmts blocks
-  flatten (CgStmt _ : stmts) blocks = flatten stmts blocks
+  flatten0 (CgLast _ : stmts) blocks = flatten0 stmts blocks
+  flatten0 (CgStmt _ : stmts) blocks = flatten0 stmts blocks
 
   --
   -- flatten1: we have a partial block, collect statements until the
-  -- next last node to make a block, then call flatten to get the rest
+  -- next last node to make a block, then call flatten0 to get the rest
   -- of the blocks
   --
   flatten1 :: [CgStmt] -> Block CmmNode C O
@@ -112,7 +116,7 @@ flattenCmmAGraph id stmts =
     = blockJoinTail block (CmmBranch (entryLabel block)) : blocks
 
   flatten1 (CgLast stmt : stmts) block blocks
-    = block' : flatten stmts blocks
+    = block' : flatten0 stmts blocks
     where !block' = blockJoinTail block stmt
 
   flatten1 (CgStmt stmt : stmts) block blocks
@@ -120,8 +124,7 @@ flattenCmmAGraph id stmts =
     where !block' = blockSnoc block stmt
 
   flatten1 (CgFork fork_id stmts : rest) block blocks
-    = flatten1 (fromOL stmts) (blockJoinHead (CmmEntry fork_id) emptyBlock) $
-      flatten1 rest block blocks
+    = flatten fork_id stmts $ flatten1 rest block blocks
 
   -- a label here means that we should start a new block, and the
   -- current block should fall through to the new block.
@@ -228,11 +231,6 @@ mkReturn dflags e actuals updfr_off =
   lastWithArgs dflags Ret  Old NativeReturn actuals updfr_off $
     toCall e Nothing updfr_off 0
 
-mkReturnSimple  :: DynFlags -> [CmmActual] -> UpdFrameOffset -> CmmAGraph
-mkReturnSimple dflags actuals updfr_off =
-  mkReturn dflags e actuals updfr_off
-  where e = CmmLoad (CmmStackSlot Old updfr_off) (gcWord dflags)
-
 mkBranch        :: BlockId -> CmmAGraph
 mkBranch bid     = mkLast (CmmBranch bid)
 
diff --git a/compiler/cmm/OldCmmLint.hs b/compiler/cmm/OldCmmLint.hs
index 5dd3209892..f158369b13 100644
--- a/compiler/cmm/OldCmmLint.hs
+++ b/compiler/cmm/OldCmmLint.hs
@@ -19,7 +19,6 @@ module OldCmmLint (
 
 import BlockId
 import OldCmm
-import CLabel
 import Outputable
 import OldPprCmm()
 import FastString
@@ -50,10 +49,9 @@ runCmmLint _ l p =
 
 lintCmmDecl :: DynFlags -> (GenCmmDecl h i (ListGraph CmmStmt)) -> CmmLint ()
 lintCmmDecl dflags (CmmProc _ lbl (ListGraph blocks))
-  = addLintInfo (text "in proc " <> pprCLabel platform lbl) $
+  = addLintInfo (text "in proc " <> ppr lbl) $
         let labels = foldl (\s b -> setInsert (blockId b) s) setEmpty blocks
         in  mapM_ (lintCmmBlock dflags labels) blocks
-    where platform = targetPlatform dflags
 
 lintCmmDecl _ (CmmData {})
   = return ()
diff --git a/compiler/cmm/PprCmmDecl.hs b/compiler/cmm/PprCmmDecl.hs
index d2491d3089..2cb90e9a22 100644
--- a/compiler/cmm/PprCmmDecl.hs
+++ b/compiler/cmm/PprCmmDecl.hs
@@ -38,13 +38,11 @@ module PprCmmDecl
     )
 where
 
-import CLabel
 import PprCmmExpr
 import Cmm
 
 import DynFlags
 import Outputable
-import Platform
 import FastString
 
 import Data.List
@@ -72,7 +70,7 @@ instance (Outputable d, Outputable info, Outputable i)
     ppr t = pprTop t
 
 instance Outputable CmmStatics where
-    ppr x = sdocWithPlatform $ \platform -> pprStatics platform x
+    ppr = pprStatics
 
 instance Outputable CmmStatic where
     ppr = pprStatic
@@ -141,9 +139,8 @@ instance Outputable ForeignHint where
 --      Strings are printed as C strings, and we print them as I8[],
 --      following C--
 --
-pprStatics :: Platform -> CmmStatics -> SDoc
-pprStatics platform (Statics lbl ds)
-    = vcat ((pprCLabel platform lbl <> colon) : map ppr ds)
+pprStatics :: CmmStatics -> SDoc
+pprStatics (Statics lbl ds) = vcat ((ppr lbl <> colon) : map ppr ds)
 
 pprStatic :: CmmStatic -> SDoc
 pprStatic s = case s of
diff --git a/compiler/codeGen/CgProf.hs b/compiler/codeGen/CgProf.hs
index 5537e575d4..c124b5f68a 100644
--- a/compiler/codeGen/CgProf.hs
+++ b/compiler/codeGen/CgProf.hs
@@ -23,8 +23,6 @@ module CgProf (
   ) where
 
 #include "HsVersions.h"
-#include "../includes/dist-derivedconstants/header/DerivedConstants.h"
-        -- For REP_xxx constants, which are MachReps
 
 import ClosureInfo
 import CgUtils
@@ -110,6 +108,7 @@ profAlloc :: CmmExpr -> CmmExpr -> Code
 profAlloc words ccs
   = ifProfiling $
     do dflags <- getDynFlags
+       let alloc_rep = typeWidth (rEP_CostCentreStack_mem_alloc dflags)
        stmtC (addToMemE alloc_rep
                    (cmmOffsetB dflags ccs (oFFSET_CostCentreStack_mem_alloc dflags))
                    (CmmMachOp (MO_UU_Conv (wordWidth dflags) alloc_rep) $
@@ -117,8 +116,6 @@ profAlloc words ccs
                                                      mkIntExpr dflags (profHdrSize dflags)]]))
                    -- subtract the "profiling overhead", which is the
                    -- profiling header in a closure.
- where
-   alloc_rep = typeWidth REP_CostCentreStack_mem_alloc
 
 -- -----------------------------------------------------------------------
 -- Setting the current cost centre on entry to a closure
@@ -215,7 +212,7 @@ sizeof_ccs_words dflags
   | ms == 0   = ws
   | otherwise = ws + 1
   where
-   (ws,ms) = SIZEOF_CostCentreStack `divMod` wORD_SIZE dflags
+   (ws,ms) = sIZEOF_CostCentreStack dflags `divMod` wORD_SIZE dflags
 
 -- ---------------------------------------------------------------------------
 -- Set the current cost centre stack
@@ -239,7 +236,7 @@ pushCostCentre result ccs cc
 
 bumpSccCount :: DynFlags -> CmmExpr -> CmmStmt
 bumpSccCount dflags ccs
-  = addToMem (typeWidth REP_CostCentreStack_scc_count)
+  = addToMem (typeWidth (rEP_CostCentreStack_scc_count dflags))
          (cmmOffsetB dflags ccs (oFFSET_CostCentreStack_scc_count dflags)) 1
 
 -----------------------------------------------------------------------------
diff --git a/compiler/codeGen/CgTicky.hs b/compiler/codeGen/CgTicky.hs
index 79215f6582..21837e787b 100644
--- a/compiler/codeGen/CgTicky.hs
+++ b/compiler/codeGen/CgTicky.hs
@@ -43,9 +43,6 @@ module CgTicky (
        staticTickyHdr,
   ) where
 
-#include "../includes/dist-derivedconstants/header/DerivedConstants.h"
-	-- For REP_xxx constants, which are MachReps
-
 import ClosureInfo
 import CgUtils
 import CgMonad
@@ -298,7 +295,7 @@ tickyAllocHeap hp
 	  if hp == 0 then [] 	-- Inside the stmtC to avoid control
 	  else [		-- dependency on the argument
 		-- Bump the allcoation count in the StgEntCounter
-	    addToMem (typeWidth REP_StgEntCounter_allocs)
+	    addToMem (typeWidth (rEP_StgEntCounter_allocs dflags))
 			(CmmLit (cmmLabelOffB ticky_ctr 
 				(oFFSET_StgEntCounter_allocs dflags))) hp,
 		-- Bump ALLOC_HEAP_ctr
diff --git a/compiler/codeGen/CodeGen.lhs b/compiler/codeGen/CodeGen.lhs
deleted file mode 100644
index 311f947248..0000000000
--- a/compiler/codeGen/CodeGen.lhs
+++ /dev/null
@@ -1,234 +0,0 @@
-%
-% (c) The University of Glasgow 2006
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-%
-
-The Code Generator
-
-This module says how things get going at the top level.
-
-@codeGen@ is the interface to the outside world. The \tr{cgTop*}
-functions drive the mangling of top-level bindings.
-
-\begin{code}
-
-module CodeGen ( codeGen ) where
-
-#include "HsVersions.h"
-
--- Required so that CgExpr is reached via at least one non-SOURCE
--- import. Before, that wasn't the case, and CM therefore didn't
--- bother to compile it.
-import CgExpr ( {-NOTHING!-} ) -- DO NOT DELETE THIS IMPORT
-import CgProf
-import CgMonad
-import CgBindery
-import CgClosure
-import CgCon
-import CgUtils
-import CgHpc
-
-import CLabel
-import OldCmm
-import OldPprCmm ()
-
-import StgSyn
-import PrelNames
-import DynFlags
-
-import HscTypes
-import CostCentre
-import Id
-import Name
-import TyCon
-import Module
-import ErrUtils
-import Panic
-import Outputable
-import Util
-
-import OrdList
-import Stream (Stream, liftIO)
-import qualified Stream
-
-import Data.IORef
-
-codeGen :: DynFlags
-        -> Module                     -- Module we are compiling
-        -> [TyCon]                    -- Type constructors
-        -> CollectedCCs               -- (Local/global) cost-centres needing declaring/registering.
-        -> [(StgBinding,[(Id,[Id])])] -- Bindings to convert, with SRTs
-        -> HpcInfo                    -- Profiling info
-        -> Stream IO CmmGroup ()
-              -- N.B. returning '[Cmm]' and not 'Cmm' here makes it
-              -- possible for object splitting to split up the
-              -- pieces later.
-
-codeGen dflags this_mod data_tycons cost_centre_info stg_binds hpc_info
-
-   = do { liftIO $ showPass dflags "CodeGen"
-
-        ; cgref <- liftIO $ newIORef =<< initC
-        ; let cg :: FCode CmmGroup -> Stream IO CmmGroup ()
-              cg fcode = do
-                cmm <- liftIO $ do
-                         st <- readIORef cgref
-                         let (a,st') = runC dflags this_mod st fcode
-
-                         dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" $ ppr a
-
-                         -- NB. stub-out cgs_tops and cgs_stmts.  This fixes
-                         -- a big space leak.  DO NOT REMOVE!
-                         writeIORef cgref $! st'{ cgs_tops = nilOL,
-                                                  cgs_stmts = nilOL }
-                         return a
-                Stream.yield cmm
-
-        ; cg (getCmm $ mkModuleInit dflags cost_centre_info this_mod hpc_info)
-
-        ; mapM_ (cg . getCmm . cgTopBinding dflags) stg_binds
-
-        ; mapM_ (cg . cgTyCon) data_tycons
-        }
-
-mkModuleInit
-        :: DynFlags
-        -> CollectedCCs         -- cost centre info
-        -> Module
-        -> HpcInfo
-        -> Code
-
-mkModuleInit dflags cost_centre_info this_mod hpc_info
-  = do  { -- Allocate the static boolean that records if this
-        ; whenC (dopt Opt_Hpc dflags) $
-              hpcTable this_mod hpc_info
-
-        ; whenC (dopt Opt_SccProfilingOn dflags) $ do
-            initCostCentres cost_centre_info
-
-            -- For backwards compatibility: user code may refer to this
-            -- label for calling hs_add_root().
-        ; emitDecl (CmmData Data (Statics (mkPlainModuleInitLabel this_mod) []))
-
-        ; whenC (this_mod == mainModIs dflags) $
-             emitSimpleProc (mkPlainModuleInitLabel rOOT_MAIN) $ return ()
-    }
-\end{code}
-
-
-
-Cost-centre profiling: Besides the usual stuff, we must produce
-declarations for the cost-centres defined in this module;
-
-(The local cost-centres involved in this are passed into the
-code-generator.)
-
-\begin{code}
-initCostCentres :: CollectedCCs -> Code
--- Emit the declarations, and return code to register them
-initCostCentres (local_CCs, ___extern_CCs, singleton_CCSs)
-  = do dflags <- getDynFlags
-       if not (dopt Opt_SccProfilingOn dflags)
-           then nopC
-           else do mapM_ emitCostCentreDecl      local_CCs
-                   mapM_ emitCostCentreStackDecl singleton_CCSs
-\end{code}
-
-%************************************************************************
-%*                                                                      *
-\subsection[codegen-top-bindings]{Converting top-level STG bindings}
-%*                                                                      *
-%************************************************************************
-
-@cgTopBinding@ is only used for top-level bindings, since they need
-to be allocated statically (not in the heap) and need to be labelled.
-No unboxed bindings can happen at top level.
-
-In the code below, the static bindings are accumulated in the
-@MkCgState@, and transferred into the ``statics'' slot by @forkStatics@.
-This is so that we can write the top level processing in a compositional
-style, with the increasing static environment being plumbed as a state
-variable.
-
-\begin{code}
-cgTopBinding :: DynFlags -> (StgBinding,[(Id,[Id])]) -> Code
-cgTopBinding dflags (StgNonRec id rhs, srts)
-  = do  { id' <- maybeExternaliseId dflags id
-        ; mapM_ (mkSRT [id']) srts
-        ; (id,info) <- cgTopRhs id' rhs
-        ; addBindC id info      -- Add the *un-externalised* Id to the envt,
-                                -- so we find it when we look up occurrences
-        }
-
-cgTopBinding dflags (StgRec pairs, srts)
-  = do  { let (bndrs, rhss) = unzip pairs
-        ; bndrs' <- mapFCs (maybeExternaliseId dflags) bndrs
-        ; let pairs' = zip bndrs' rhss
-        ; mapM_ (mkSRT bndrs')  srts
-        ; _new_binds <- fixC (\ new_binds -> do
-                { addBindsC new_binds
-                ; mapFCs ( \ (b,e) -> cgTopRhs b e ) pairs' })
-        ; nopC }
-
-mkSRT :: [Id] -> (Id,[Id]) -> Code
-mkSRT _ (_,[])  = nopC
-mkSRT these (id,ids)
-  = do  { ids <- mapFCs remap ids
-        ; id  <- remap id
-        ; emitRODataLits "CodeGen.mkSRT" (mkSRTLabel (idName id) (idCafInfo id))
-               (map (\id -> CmmLabel $ mkClosureLabel (idName id) (idCafInfo id)) ids)
-        }
-  where
-        -- Sigh, better map all the ids against the environment in
-        -- case they've been externalised (see maybeExternaliseId below).
-    remap id = case filter (==id) these of
-                (id':_) -> returnFC id'
-                [] -> do { info <- getCgIdInfo id; return (cgIdInfoId info) }
-
--- Urgh!  I tried moving the forkStatics call from the rhss of cgTopRhs
--- to enclose the listFCs in cgTopBinding, but that tickled the
--- statics "error" call in initC.  I DON'T UNDERSTAND WHY!
-
-cgTopRhs :: Id -> StgRhs -> FCode (Id, CgIdInfo)
-        -- The Id is passed along for setting up a binding...
-        -- It's already been externalised if necessary
-
-cgTopRhs bndr (StgRhsCon _cc con args)
-  = forkStatics (cgTopRhsCon bndr con args)
-
-cgTopRhs bndr (StgRhsClosure cc bi fvs upd_flag srt args body)
-  = ASSERT(null fvs)    -- There should be no free variables
-    setSRTLabel (mkSRTLabel (idName bndr) (idCafInfo bndr)) $
-    setSRT srt $
-    forkStatics (cgTopRhsClosure bndr cc bi upd_flag args body)
-\end{code}
-
-
-%************************************************************************
-%*                                                                      *
-\subsection{Stuff to support splitting}
-%*                                                                      *
-%************************************************************************
-
-If we're splitting the object, we need to externalise all the top-level names
-(and then make sure we only use the externalised one in any C label we use
-which refers to this name).
-
-\begin{code}
-maybeExternaliseId :: DynFlags -> Id -> FCode Id
-maybeExternaliseId dflags id
-  | dopt Opt_SplitObjs dflags,  -- Externalise the name for -split-objs
-    isInternalName name = do { mod <- getModuleName
-                             ; returnFC (setIdName id (externalise mod)) }
-  | otherwise           = returnFC id
-  where
-    externalise mod = mkExternalName uniq mod new_occ loc
-    name    = idName id
-    uniq    = nameUnique name
-    new_occ = mkLocalOcc uniq (nameOccName name)
-    loc     = nameSrcSpan name
-        -- We want to conjure up a name that can't clash with any
-        -- existing name.  So we generate
-        --      Mod_$L243foo
-        -- where 243 is the unique.
-\end{code}
diff --git a/compiler/codeGen/StgCmm.hs b/compiler/codeGen/StgCmm.hs
index f1022e5280..37ca5e0d43 100644
--- a/compiler/codeGen/StgCmm.hs
+++ b/compiler/codeGen/StgCmm.hs
@@ -52,7 +52,7 @@ codeGen :: DynFlags
          -> Module
          -> [TyCon]
          -> CollectedCCs                -- (Local/global) cost-centres needing declaring/registering.
-         -> [(StgBinding,[(Id,[Id])])]  -- Bindings to convert, with SRTs
+         -> [StgBinding]                -- Bindings to convert
          -> HpcInfo
          -> Stream IO CmmGroup ()       -- Output as a stream, so codegen can
                                         -- be interleaved with output
@@ -114,8 +114,8 @@ This is so that we can write the top level processing in a compositional
 style, with the increasing static environment being plumbed as a state
 variable. -}
 
-cgTopBinding :: DynFlags -> (StgBinding,[(Id,[Id])]) -> FCode ()
-cgTopBinding dflags (StgNonRec id rhs, _srts)
+cgTopBinding :: DynFlags -> StgBinding -> FCode ()
+cgTopBinding dflags (StgNonRec id rhs)
   = do  { id' <- maybeExternaliseId dflags id
         ; (info, fcode) <- cgTopRhs id' rhs
         ; fcode
@@ -123,7 +123,7 @@ cgTopBinding dflags (StgNonRec id rhs, _srts)
                                      -- so we find it when we look up occurrences
         }
 
-cgTopBinding dflags (StgRec pairs, _srts)
+cgTopBinding dflags (StgRec pairs)
   = do  { let (bndrs, rhss) = unzip pairs
         ; bndrs' <- Prelude.mapM (maybeExternaliseId dflags) bndrs
         ; let pairs' = zip bndrs' rhss
diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs
index 02d3d0246f..89d27dd161 100644
--- a/compiler/codeGen/StgCmmBind.hs
+++ b/compiler/codeGen/StgCmmBind.hs
@@ -468,8 +468,7 @@ closureCodeBody top_lvl bndr cl_info cc args arity body fv_details
                 { fv_bindings <- mapM bind_fv fv_details
                 -- Load free vars out of closure *after*
                 -- heap check, to reduce live vars over check
-                ; if node_points then load_fvs node lf_info fv_bindings
-                                 else return ()
+                ; when node_points $ load_fvs node lf_info fv_bindings
                 ; void $ cgExpr body
                 }}
   }
diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs
index 307d3715b3..a8ffc12bb0 100644
--- a/compiler/codeGen/StgCmmExpr.hs
+++ b/compiler/codeGen/StgCmmExpr.hs
@@ -163,9 +163,7 @@ cgLetNoEscapeClosure bndr cc_slot _unused_cc args body
    code = forkProc $ do
                   { restoreCurrentCostCentre cc_slot
                   ; arg_regs <- bindArgsToRegs args
-                  ; void $ altHeapCheck arg_regs (cgExpr body) }
-                        -- Using altHeapCheck just reduces
-                        -- instructions to save on stack
+                  ; void $ noEscapeHeapCheck arg_regs (cgExpr body) }
 
 
 ------------------------------------------------------------------------
diff --git a/compiler/codeGen/StgCmmHeap.hs b/compiler/codeGen/StgCmmHeap.hs
index fb3739177c..b7cca48f5a 100644
--- a/compiler/codeGen/StgCmmHeap.hs
+++ b/compiler/codeGen/StgCmmHeap.hs
@@ -10,7 +10,7 @@ module StgCmmHeap (
         getVirtHp, setVirtHp, setRealHp,
         getHpRelOffset, hpRel,
 
-        entryHeapCheck, altHeapCheck, altHeapCheckReturnsTo,
+        entryHeapCheck, altHeapCheck, noEscapeHeapCheck, altHeapCheckReturnsTo,
 
         mkVirtHeapOffsets, mkVirtConstrOffsets,
         mkStaticClosureFields, mkStaticClosure,
@@ -371,7 +371,7 @@ entryHeapCheck cl_info nodeSet arity args code
 
        loop_id <- newLabelC
        emitLabel loop_id
-       heapCheck True (gc_call updfr_sz <*> mkBranch loop_id) code
+       heapCheck True True (gc_call updfr_sz <*> mkBranch loop_id) code
 
 {-
     -- This code is slightly outdated now and we could easily keep the above
@@ -436,32 +436,41 @@ entryHeapCheck cl_info nodeSet arity args code
 --           else we do a normal call to stg_gc_noregs
 
 altHeapCheck :: [LocalReg] -> FCode a -> FCode a
-altHeapCheck regs code = do
+altHeapCheck regs code = altOrNoEscapeHeapCheck False regs code
+
+altOrNoEscapeHeapCheck :: Bool -> [LocalReg] -> FCode a -> FCode a
+altOrNoEscapeHeapCheck checkYield regs code = do
     dflags <- getDynFlags
     case cannedGCEntryPoint dflags regs of
-      Nothing -> genericGC code
+      Nothing -> genericGC checkYield code
       Just gc -> do
         lret <- newLabelC
         let (off, copyin) = copyInOflow dflags NativeReturn (Young lret) regs
         lcont <- newLabelC
         emitOutOfLine lret (copyin <*> mkBranch lcont)
         emitLabel lcont
-        cannedGCReturnsTo False gc regs lret off code
+        cannedGCReturnsTo checkYield False gc regs lret off code
 
 altHeapCheckReturnsTo :: [LocalReg] -> Label -> ByteOff -> FCode a -> FCode a
 altHeapCheckReturnsTo regs lret off code
   = do dflags <- getDynFlags
        case cannedGCEntryPoint dflags regs of
-           Nothing -> genericGC code
-           Just gc -> cannedGCReturnsTo True gc regs lret off code
+           Nothing -> genericGC False code
+           Just gc -> cannedGCReturnsTo False True gc regs lret off code
+
+-- noEscapeHeapCheck is implemented identically to altHeapCheck (which
+-- is more efficient), but cannot be optimized away in the non-allocating
+-- case because it may occur in a loop
+noEscapeHeapCheck :: [LocalReg] -> FCode a -> FCode a
+noEscapeHeapCheck regs code = altOrNoEscapeHeapCheck True regs code
 
-cannedGCReturnsTo :: Bool -> CmmExpr -> [LocalReg] -> Label -> ByteOff
+cannedGCReturnsTo :: Bool -> Bool -> CmmExpr -> [LocalReg] -> Label -> ByteOff
                   -> FCode a
                   -> FCode a
-cannedGCReturnsTo cont_on_stack gc regs lret off code
+cannedGCReturnsTo checkYield cont_on_stack gc regs lret off code
   = do dflags <- getDynFlags
        updfr_sz <- getUpdFrameOff
-       heapCheck False (gc_call dflags gc updfr_sz) code
+       heapCheck False checkYield (gc_call dflags gc updfr_sz) code
   where
     reg_exprs = map (CmmReg . CmmLocal) regs
       -- Note [stg_gc arguments]
@@ -470,13 +479,13 @@ cannedGCReturnsTo cont_on_stack gc regs lret off code
       | cont_on_stack = mkJumpReturnsTo dflags label GC reg_exprs lret off sp
       | otherwise     = mkCallReturnsTo dflags label GC reg_exprs lret off sp (0,[])
 
-genericGC :: FCode a -> FCode a
-genericGC code
+genericGC :: Bool -> FCode a -> FCode a
+genericGC checkYield code
   = do updfr_sz <- getUpdFrameOff
        lretry <- newLabelC
        emitLabel lretry
        call <- mkCall generic_gc (GC, GC) [] [] updfr_sz (0,[])
-       heapCheck False (call <*> mkBranch lretry) code
+       heapCheck False checkYield (call <*> mkBranch lretry) code
 
 cannedGCEntryPoint :: DynFlags -> [LocalReg] -> Maybe CmmExpr
 cannedGCEntryPoint dflags regs
@@ -524,22 +533,23 @@ mkGcLabel :: String -> CmmExpr
 mkGcLabel s = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit s)))
 
 -------------------------------
-heapCheck :: Bool -> CmmAGraph -> FCode a -> FCode a
-heapCheck checkStack do_gc code
+heapCheck :: Bool -> Bool -> CmmAGraph -> FCode a -> FCode a
+heapCheck checkStack checkYield do_gc code
   = getHeapUsage $ \ hpHw ->
     -- Emit heap checks, but be sure to do it lazily so
     -- that the conditionals on hpHw don't cause a black hole
-    do  { codeOnly $ do_checks checkStack hpHw do_gc
+    do  { codeOnly $ do_checks checkStack checkYield hpHw do_gc
         ; tickyAllocHeap hpHw
         ; doGranAllocate hpHw
         ; setRealHp hpHw
         ; code }
 
 do_checks :: Bool       -- Should we check the stack?
+          -> Bool       -- Should we check for preemption?
           -> WordOff    -- Heap headroom
           -> CmmAGraph  -- What to do on failure
           -> FCode ()
-do_checks checkStack alloc do_gc = do
+do_checks checkStack checkYield alloc do_gc = do
   dflags <- getDynFlags
   let
     alloc_lit = mkIntExpr dflags (alloc * wORD_SIZE dflags) -- Bytes
@@ -557,15 +567,22 @@ do_checks checkStack alloc do_gc = do
     hp_oflo = CmmMachOp (mo_wordUGt dflags)
                         [CmmReg hpReg, CmmReg (CmmGlobal HpLim)]
 
+    -- Yielding if HpLim == 0
+    yielding = CmmMachOp (mo_wordEq dflags)
+                        [CmmReg (CmmGlobal HpLim), CmmLit (zeroCLit dflags)]
+
     alloc_n = mkAssign (CmmGlobal HpAlloc) alloc_lit
   gc_id <- newLabelC
 
   when checkStack $ do
      emit =<< mkCmmIfGoto sp_oflo gc_id
 
-  when (alloc /= 0) $ do
-     emitAssign hpReg bump_hp
-     emit =<< mkCmmIfThen hp_oflo (alloc_n <*> mkBranch gc_id)
+  if (alloc /= 0)
+    then do
+      emitAssign hpReg bump_hp
+      emit =<< mkCmmIfThen hp_oflo (alloc_n <*> mkBranch gc_id)
+    else do
+      when (not (dopt Opt_OmitYields dflags) && checkYield) (emit =<< mkCmmIfGoto yielding gc_id)
 
   emitOutOfLine gc_id $
      do_gc -- this is expected to jump back somewhere
diff --git a/compiler/codeGen/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs
index 69a0d1a0cf..75d8d1c38f 100644
--- a/compiler/codeGen/StgCmmLayout.hs
+++ b/compiler/codeGen/StgCmmLayout.hs
@@ -61,6 +61,7 @@ import Util
 import Data.List
 import Outputable
 import FastString
+import Control.Monad
 
 ------------------------------------------------------------------------
 --		Call and return sequences
@@ -84,9 +85,11 @@ emitReturn results
        ; case sequel of
            Return _ ->
              do { adjustHpBackwards
-                ; emit (mkReturnSimple dflags results updfr_off) }
+                ; let e = CmmLoad (CmmStackSlot Old updfr_off) (gcWord dflags)
+                ; emit (mkReturn dflags (entryCode dflags e) results updfr_off)
+                }
            AssignTo regs adjust ->
-             do { if adjust then adjustHpBackwards else return ()
+             do { when adjust adjustHpBackwards
                 ; emitMultiAssign  regs results }
        ; return AssignedDirectly
        }
diff --git a/compiler/codeGen/StgCmmProf.hs b/compiler/codeGen/StgCmmProf.hs
index ba65a556b2..b666554403 100644
--- a/compiler/codeGen/StgCmmProf.hs
+++ b/compiler/codeGen/StgCmmProf.hs
@@ -31,8 +31,6 @@ module StgCmmProf (
   ) where
 
 #include "HsVersions.h"
-#include "../includes/dist-derivedconstants/header/DerivedConstants.h"
-	-- For REP_xxx constants, which are MachReps
 
 import StgCmmClosure
 import StgCmmUtils
@@ -169,6 +167,7 @@ profAlloc :: CmmExpr -> CmmExpr -> FCode ()
 profAlloc words ccs
   = ifProfiling $
         do dflags <- getDynFlags
+           let alloc_rep = rEP_CostCentreStack_mem_alloc dflags
            emit (addToMemE alloc_rep
                        (cmmOffsetB dflags ccs (oFFSET_CostCentreStack_mem_alloc dflags))
                        (CmmMachOp (MO_UU_Conv (wordWidth dflags) (typeWidth alloc_rep)) $
@@ -176,8 +175,6 @@ profAlloc words ccs
                                                          mkIntExpr dflags (profHdrSize dflags)]]))
                        -- subtract the "profiling overhead", which is the
                        -- profiling header in a closure.
- where 
-        alloc_rep =  REP_CostCentreStack_mem_alloc
 
 -- -----------------------------------------------------------------------
 -- Setting the current cost centre on entry to a closure
@@ -277,7 +274,7 @@ sizeof_ccs_words dflags
   | ms == 0   = ws
   | otherwise = ws + 1
   where
-   (ws,ms) = SIZEOF_CostCentreStack `divMod` wORD_SIZE dflags
+   (ws,ms) = sIZEOF_CostCentreStack dflags `divMod` wORD_SIZE dflags
 
 -- ---------------------------------------------------------------------------
 -- Set the current cost centre stack
@@ -302,7 +299,7 @@ pushCostCentre result ccs cc
 
 bumpSccCount :: DynFlags -> CmmExpr -> CmmAGraph
 bumpSccCount dflags ccs
-  = addToMem REP_CostCentreStack_scc_count
+  = addToMem (rEP_CostCentreStack_scc_count dflags)
 	 (cmmOffsetB dflags ccs (oFFSET_CostCentreStack_scc_count dflags)) 1
 
 -----------------------------------------------------------------------------
diff --git a/compiler/codeGen/StgCmmTicky.hs b/compiler/codeGen/StgCmmTicky.hs
index d7517e8256..79ad3ff822 100644
--- a/compiler/codeGen/StgCmmTicky.hs
+++ b/compiler/codeGen/StgCmmTicky.hs
@@ -46,8 +46,6 @@ module StgCmmTicky (
   ) where
 
 #include "HsVersions.h"
-#include "../includes/dist-derivedconstants/header/DerivedConstants.h"
-	-- For REP_xxx constants, which are MachReps
 
 import StgCmmClosure
 import StgCmmUtils
@@ -321,7 +319,7 @@ tickyAllocHeap hp
 	  if hp == 0 then [] 	-- Inside the emitMiddle to avoid control
 	  else [		-- dependency on the argument
 		-- Bump the allcoation count in the StgEntCounter
-	    addToMem REP_StgEntCounter_allocs 
+	    addToMem (rEP_StgEntCounter_allocs dflags)
 			(CmmLit (cmmLabelOffB ticky_ctr 
 				(oFFSET_StgEntCounter_allocs dflags))) hp,
 		-- Bump ALLOC_HEAP_ctr
diff --git a/compiler/codeGen/StgCmmUtils.hs b/compiler/codeGen/StgCmmUtils.hs
index f5dc2b6d31..386e7f46d6 100644
--- a/compiler/codeGen/StgCmmUtils.hs
+++ b/compiler/codeGen/StgCmmUtils.hs
@@ -37,9 +37,7 @@ module StgCmmUtils (
         mkWordCLit,
         newStringCLit, newByteStringCLit,
         packHalfWordsCLit,
-        blankWord,
-
-        srt_escape
+        blankWord
   ) where
 
 #include "HsVersions.h"
@@ -719,6 +717,3 @@ assignTemp' e
        let reg = CmmLocal lreg
        emitAssign reg e
        return (CmmReg reg)
-
-srt_escape :: DynFlags -> StgHalfWord
-srt_escape dflags = toStgHalfWord dflags (-1)
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index f07cccffe0..6d83150eb6 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -245,7 +245,6 @@ Library
         StgCmmTicky
         StgCmmUtils
         ClosureInfo
-        CodeGen
         SMRep
         CoreArity
         CoreFVs
@@ -364,7 +363,6 @@ Library
         SimplMonad
         SimplUtils
         Simplify
-        SRT
         SimplStg
         StgStats
         UnariseStg
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index c0667b02d1..7ae46532c5 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -293,6 +293,7 @@ data DynFlag
    | Opt_IrrefutableTuples
    | Opt_CmmSink
    | Opt_CmmElimCommonBlocks
+   | Opt_OmitYields
 
    -- Interface files
    | Opt_IgnoreInterfacePragmas
@@ -348,7 +349,6 @@ data DynFlag
    | Opt_RunCPSZ
    | Opt_AutoLinkPackages
    | Opt_ImplicitImportQualified
-   | Opt_TryNewCodeGen
 
    -- keeping stuff
    | Opt_KeepHiDiffs
@@ -2268,7 +2268,6 @@ fFlags = [
   ( "print-bind-contents",              Opt_PrintBindContents, nop ),
   ( "run-cps",                          Opt_RunCPS, nop ),
   ( "run-cpsz",                         Opt_RunCPSZ, nop ),
-  ( "new-codegen",                      Opt_TryNewCodeGen, nop ),
   ( "vectorise",                        Opt_Vectorise, nop ),
   ( "avoid-vect",                       Opt_AvoidVect, nop ),
   ( "regs-graph",                       Opt_RegsGraph, nop ),
@@ -2278,6 +2277,7 @@ fFlags = [
   ( "irrefutable-tuples",               Opt_IrrefutableTuples, nop ),
   ( "cmm-sink",                         Opt_CmmSink, nop ),
   ( "cmm-elim-common-blocks",           Opt_CmmElimCommonBlocks, nop ),
+  ( "omit-yields",                      Opt_OmitYields, nop ),
   ( "gen-manifest",                     Opt_GenManifest, nop ),
   ( "embed-manifest",                   Opt_EmbedManifest, nop ),
   ( "ext-core",                         Opt_EmitExternalCore, nop ),
@@ -2425,9 +2425,8 @@ xFlags = [
   ( "MultiWayIf",                       Opt_MultiWayIf, nop ),
   ( "MonoLocalBinds",                   Opt_MonoLocalBinds, nop ),
   ( "RelaxedPolyRec",                   Opt_RelaxedPolyRec,
-    \ turn_on -> if not turn_on
-                 then deprecate "You can't turn off RelaxedPolyRec any more"
-                 else return () ),
+    \ turn_on -> unless turn_on
+               $ deprecate "You can't turn off RelaxedPolyRec any more" ),
   ( "ExtendedDefaultRules",             Opt_ExtendedDefaultRules, nop ),
   ( "ImplicitParams",                   Opt_ImplicitParams, nop ),
   ( "ScopedTypeVariables",              Opt_ScopedTypeVariables, nop ),
@@ -2464,7 +2463,7 @@ defaultFlags platform
 
       Opt_SharedImplib,
 
-      Opt_TryNewCodeGen,
+      Opt_OmitYields,
 
       Opt_GenManifest,
       Opt_EmbedManifest,
diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs
index 6f9745dbfc..f04ca020e2 100644
--- a/compiler/main/HscMain.hs
+++ b/compiler/main/HscMain.hs
@@ -75,6 +75,7 @@ module HscMain
     ) where
 
 #ifdef GHCI
+import Id
 import ByteCodeGen      ( byteCodeGen, coreExprToBCOs )
 import Linker
 import CoreTidy         ( tidyExpr )
@@ -90,7 +91,6 @@ import Panic
 import GHC.Exts
 #endif
 
-import Id
 import Module
 import Packages
 import RdrName
@@ -119,7 +119,6 @@ import ProfInit
 import TyCon
 import Name
 import SimplStg         ( stg2stg )
-import CodeGen          ( codeGen )
 import qualified OldCmm as Old
 import qualified Cmm as New
 import CmmParse         ( parseCmmFile )
@@ -136,7 +135,6 @@ import Fingerprint      ( Fingerprint )
 
 import DynFlags
 import ErrUtils
-import UniqSupply       ( mkSplitUniqSupply )
 
 import Outputable
 import HscStats         ( ppSourceStats )
@@ -144,7 +142,7 @@ import HscTypes
 import MkExternalCore   ( emitExternalCore )
 import FastString
 import UniqFM           ( emptyUFM )
-import UniqSupply       ( initUs_ )
+import UniqSupply
 import Bag
 import Exception
 import qualified Stream
@@ -1285,16 +1283,10 @@ hscGenHardCode cgguts mod_summary = do
 
         ------------------  Code generation ------------------
 
-        cmms <- if dopt Opt_TryNewCodeGen dflags
-                    then {-# SCC "NewCodeGen" #-}
+        cmms <- {-# SCC "NewCodeGen" #-}
                          tryNewCodeGen hsc_env this_mod data_tycons
                              cost_centre_info
                              stg_binds hpc_info
-                    else {-# SCC "CodeGen" #-}
-                         return (codeGen dflags this_mod data_tycons
-                               cost_centre_info
-                               stg_binds hpc_info)
-
 
         ------------------  Code output -----------------------
         rawcmms0 <- {-# SCC "cmmToRawCmm" #-}
@@ -1370,7 +1362,7 @@ hscCompileCmmFile hsc_env filename = runHsc hsc_env $ do
 
 tryNewCodeGen   :: HscEnv -> Module -> [TyCon]
                 -> CollectedCCs
-                -> [(StgBinding,[(Id,[Id])])]
+                -> [StgBinding]
                 -> HpcInfo
                 -> IO (Stream IO Old.CmmGroup ())
          -- Note we produce a 'Stream' of CmmGroups, so that the
@@ -1399,17 +1391,33 @@ tryNewCodeGen hsc_env this_mod data_tycons
     -- We are building a single SRT for the entire module, so
     -- we must thread it through all the procedures as we cps-convert them.
     us <- mkSplitUniqSupply 'S'
-    let srt_mod | dopt Opt_SplitObjs dflags = Just this_mod
-                | otherwise                 = Nothing
-        initTopSRT = initUs_ us (emptySRT srt_mod)
 
-    let run_pipeline topSRT cmmgroup = do
-           (topSRT, cmmgroup) <- cmmPipeline hsc_env topSRT cmmgroup
-           return (topSRT,cmmOfZgraph cmmgroup)
-
-    let pipeline_stream = {-# SCC "cmmPipeline" #-} do
-          topSRT <- Stream.mapAccumL run_pipeline initTopSRT ppr_stream1
-          Stream.yield (cmmOfZgraph (srtToData topSRT))
+    -- When splitting, we generate one SRT per split chunk, otherwise
+    -- we generate one SRT for the whole module.
+    let
+     pipeline_stream
+      | dopt Opt_SplitObjs dflags
+        = {-# SCC "cmmPipeline" #-}
+          let run_pipeline us cmmgroup = do
+                let (topSRT', us') = initUs us emptySRT
+                (topSRT, cmmgroup) <- cmmPipeline hsc_env topSRT' cmmgroup
+                let srt | isEmptySRT topSRT = []
+                        | otherwise         = srtToData topSRT
+                return (us',cmmOfZgraph (srt ++ cmmgroup))
+
+          in do _ <- Stream.mapAccumL run_pipeline us ppr_stream1
+                return ()
+
+      | otherwise
+        = {-# SCC "cmmPipeline" #-}
+          let initTopSRT = initUs_ us emptySRT in
+  
+          let run_pipeline topSRT cmmgroup = do
+                (topSRT, cmmgroup) <- cmmPipeline hsc_env topSRT cmmgroup
+                return (topSRT,cmmOfZgraph cmmgroup)
+  
+          in do topSRT <- Stream.mapAccumL run_pipeline initTopSRT ppr_stream1
+                Stream.yield (cmmOfZgraph (srtToData topSRT))
 
     let
         dump2 a = do dumpIfSet_dyn dflags Opt_D_dump_cmmz "Output Cmm" $ ppr a
@@ -1422,7 +1430,7 @@ tryNewCodeGen hsc_env this_mod data_tycons
 
 
 myCoreToStg :: DynFlags -> Module -> CoreProgram
-            -> IO ( [(StgBinding,[(Id,[Id])])] -- output program
+            -> IO ( [StgBinding] -- output program
                   , CollectedCCs) -- cost centre info (declared and used)
 myCoreToStg dflags this_mod prepd_binds = do
     stg_binds
diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs
index 8c608f1bf1..47fd96c426 100644
--- a/compiler/nativeGen/AsmCodeGen.lhs
+++ b/compiler/nativeGen/AsmCodeGen.lhs
@@ -51,7 +51,7 @@ import NCGMonad
 import BlockId
 import CgUtils          ( fixStgRegisters )
 import OldCmm
-import CmmOpt           ( cmmEliminateDeadBlocks, cmmMiniInline, cmmMachOpFold )
+import CmmOpt           ( cmmMachOpFold )
 import OldPprCmm
 import CLabel
 
@@ -133,16 +133,17 @@ The machine-dependent bits break down as follows:
 
 data NcgImpl statics instr jumpDest = NcgImpl {
     cmmTopCodeGen             :: RawCmmDecl -> NatM [NatCmmDecl statics instr],
-    generateJumpTableForInstr :: DynFlags -> instr -> Maybe (NatCmmDecl statics instr),
+    generateJumpTableForInstr :: instr -> Maybe (NatCmmDecl statics instr),
     getJumpDestBlockId        :: jumpDest -> Maybe BlockId,
     canShortcut               :: instr -> Maybe jumpDest,
     shortcutStatics           :: (BlockId -> Maybe jumpDest) -> statics -> statics,
     shortcutJump              :: (BlockId -> Maybe jumpDest) -> instr -> instr,
     pprNatCmmDecl             :: NatCmmDecl statics instr -> SDoc,
-    maxSpillSlots             :: DynFlags -> Int,
-    allocatableRegs           :: Platform -> [RealReg],
+    maxSpillSlots             :: Int,
+    allocatableRegs           :: [RealReg],
     ncg_x86fp_kludge          :: [NatCmmDecl statics instr] -> [NatCmmDecl statics instr],
     ncgExpandTop              :: [NatCmmDecl statics instr] -> [NatCmmDecl statics instr],
+    ncgAllocMoreStack         :: Int -> NatCmmDecl statics instr -> NatCmmDecl statics instr,
     ncgMakeFarBranches        :: [NatBasicBlock instr] -> [NatBasicBlock instr]
     }
 
@@ -154,15 +155,16 @@ nativeCodeGen dflags h us cmms
        nCG' ncgImpl = nativeCodeGen' dflags ncgImpl h us cmms
        x86NcgImpl = NcgImpl {
                          cmmTopCodeGen             = X86.CodeGen.cmmTopCodeGen
-                        ,generateJumpTableForInstr = X86.CodeGen.generateJumpTableForInstr
+                        ,generateJumpTableForInstr = X86.CodeGen.generateJumpTableForInstr dflags
                         ,getJumpDestBlockId        = X86.Instr.getJumpDestBlockId
                         ,canShortcut               = X86.Instr.canShortcut
                         ,shortcutStatics           = X86.Instr.shortcutStatics
                         ,shortcutJump              = X86.Instr.shortcutJump
                         ,pprNatCmmDecl              = X86.Ppr.pprNatCmmDecl
-                        ,maxSpillSlots             = X86.Instr.maxSpillSlots
-                        ,allocatableRegs           = X86.Regs.allocatableRegs
+                        ,maxSpillSlots             = X86.Instr.maxSpillSlots dflags
+                        ,allocatableRegs           = X86.Regs.allocatableRegs platform
                         ,ncg_x86fp_kludge          = id
+                        ,ncgAllocMoreStack         = X86.Instr.allocMoreStack platform
                         ,ncgExpandTop              = id
                         ,ncgMakeFarBranches        = id
                     }
@@ -172,30 +174,32 @@ nativeCodeGen dflags h us cmms
                  ArchPPC ->
                      nCG' $ NcgImpl {
                           cmmTopCodeGen             = PPC.CodeGen.cmmTopCodeGen
-                         ,generateJumpTableForInstr = PPC.CodeGen.generateJumpTableForInstr
+                         ,generateJumpTableForInstr = PPC.CodeGen.generateJumpTableForInstr dflags
                          ,getJumpDestBlockId        = PPC.RegInfo.getJumpDestBlockId
                          ,canShortcut               = PPC.RegInfo.canShortcut
                          ,shortcutStatics           = PPC.RegInfo.shortcutStatics
                          ,shortcutJump              = PPC.RegInfo.shortcutJump
                          ,pprNatCmmDecl              = PPC.Ppr.pprNatCmmDecl
-                         ,maxSpillSlots             = PPC.Instr.maxSpillSlots
-                         ,allocatableRegs           = PPC.Regs.allocatableRegs
+                         ,maxSpillSlots             = PPC.Instr.maxSpillSlots dflags
+                         ,allocatableRegs           = PPC.Regs.allocatableRegs platform
                          ,ncg_x86fp_kludge          = id
+                         ,ncgAllocMoreStack         = noAllocMoreStack
                          ,ncgExpandTop              = id
                          ,ncgMakeFarBranches        = makeFarBranches
                      }
                  ArchSPARC ->
                      nCG' $ NcgImpl {
                           cmmTopCodeGen             = SPARC.CodeGen.cmmTopCodeGen
-                         ,generateJumpTableForInstr = SPARC.CodeGen.generateJumpTableForInstr
+                         ,generateJumpTableForInstr = SPARC.CodeGen.generateJumpTableForInstr dflags
                          ,getJumpDestBlockId        = SPARC.ShortcutJump.getJumpDestBlockId
                          ,canShortcut               = SPARC.ShortcutJump.canShortcut
                          ,shortcutStatics           = SPARC.ShortcutJump.shortcutStatics
                          ,shortcutJump              = SPARC.ShortcutJump.shortcutJump
                          ,pprNatCmmDecl              = SPARC.Ppr.pprNatCmmDecl
-                         ,maxSpillSlots             = SPARC.Instr.maxSpillSlots
-                         ,allocatableRegs           = \_ -> SPARC.Regs.allocatableRegs
+                         ,maxSpillSlots             = SPARC.Instr.maxSpillSlots dflags
+                         ,allocatableRegs           = SPARC.Regs.allocatableRegs
                          ,ncg_x86fp_kludge          = id
+                         ,ncgAllocMoreStack         = noAllocMoreStack
                          ,ncgExpandTop              = map SPARC.CodeGen.Expand.expandTop
                          ,ncgMakeFarBranches        = id
                      }
@@ -206,6 +210,23 @@ nativeCodeGen dflags h us cmms
                  ArchUnknown ->
                      panic "nativeCodeGen: No NCG for unknown arch"
 
+
+--
+-- Allocating more stack space for spilling is currently only
+-- supported for the linear register allocator on x86/x86_64, the rest
+-- default to the panic below.  To support allocating extra stack on
+-- more platforms provide a definition of ncgAllocMoreStack.
+--
+noAllocMoreStack :: Int -> NatCmmDecl statics instr -> NatCmmDecl statics instr
+noAllocMoreStack amount _
+  = panic $   "Register allocator: out of stack slots (need " ++ show amount ++ ")\n"
+        ++  "   If you are trying to compile SHA1.hs from the crypto library then this\n"
+        ++  "   is a known limitation in the linear allocator.\n"
+        ++  "\n"
+        ++  "   Try enabling the graph colouring allocator with -fregs-graph instead."
+        ++  "   You can still file a bug report if you like.\n"
+
+
 nativeCodeGen' :: (Outputable statics, Outputable instr, Instruction instr)
                => DynFlags
                -> NcgImpl statics instr jumpDest
@@ -419,7 +440,7 @@ cmmNativeGen dflags ncgImpl us cmm count
                         = foldr (\r -> plusUFM_C unionUniqSets
                                         $ unitUFM (targetClassOfRealReg platform r) (unitUniqSet r))
                                 emptyUFM
-                        $ allocatableRegs ncgImpl platform
+                        $ allocatableRegs ncgImpl
 
                 -- do the graph coloring register allocation
                 let ((alloced, regAllocStats), usAlloc)
@@ -428,7 +449,7 @@ cmmNativeGen dflags ncgImpl us cmm count
                           $ Color.regAlloc
                                 dflags
                                 alloc_regs
-                                (mkUniqSet [0 .. maxSpillSlots ncgImpl dflags])
+                                (mkUniqSet [0 .. maxSpillSlots ncgImpl])
                                 withLiveness
 
                 -- dump out what happened during register allocation
@@ -457,11 +478,20 @@ cmmNativeGen dflags ncgImpl us cmm count
 
           else do
                 -- do linear register allocation
+                let reg_alloc proc = do
+                       (alloced, maybe_more_stack, ra_stats) <-
+                               Linear.regAlloc dflags proc
+                       case maybe_more_stack of
+                         Nothing -> return ( alloced, ra_stats )
+                         Just amount ->
+                           return ( ncgAllocMoreStack ncgImpl amount alloced
+                                  , ra_stats )
+
                 let ((alloced, regAllocStats), usAlloc)
                         = {-# SCC "RegAlloc" #-}
                           initUs usLive
                           $ liftM unzip
-                          $ mapM (Linear.regAlloc dflags) withLiveness
+                          $ mapM reg_alloc withLiveness
 
                 dumpIfSet_dyn dflags
                         Opt_D_dump_asm_regalloc "Registers allocated"
@@ -490,7 +520,7 @@ cmmNativeGen dflags ncgImpl us cmm count
         ---- generate jump tables
         let tabled      =
                 {-# SCC "generateJumpTables" #-}
-                generateJumpTables dflags ncgImpl kludged
+                generateJumpTables ncgImpl kludged
 
         ---- shortcut branches
         let shorted     =
@@ -711,12 +741,12 @@ makeFarBranches blocks
 -- Analyzes all native code and generates data sections for all jump
 -- table instructions.
 generateJumpTables
-        :: DynFlags -> NcgImpl statics instr jumpDest
-    -> [NatCmmDecl statics instr] -> [NatCmmDecl statics instr]
-generateJumpTables dflags ncgImpl xs = concatMap f xs
+        :: NcgImpl statics instr jumpDest
+        -> [NatCmmDecl statics instr] -> [NatCmmDecl statics instr]
+generateJumpTables ncgImpl xs = concatMap f xs
     where f p@(CmmProc _ _ (ListGraph xs)) = p : concatMap g xs
           f p = [p]
-          g (BasicBlock _ xs) = catMaybes (map (generateJumpTableForInstr ncgImpl dflags) xs)
+          g (BasicBlock _ xs) = catMaybes (map (generateJumpTableForInstr ncgImpl) xs)
 
 -- -----------------------------------------------------------------------------
 -- Shortcut branches
@@ -828,15 +858,13 @@ genMachCode dflags cmmTopCodeGen cmm_top
 Here we do:
 
   (a) Constant folding
-  (b) Simple inlining: a temporary which is assigned to and then
-      used, once, can be shorted.
   (c) Position independent code and dynamic linking
         (i)  introduce the appropriate indirections
              and position independent refs
         (ii) compile a list of imported symbols
   (d) Some arch-specific optimizations
 
-(a) and (b) will be moving to the new Hoopl pipeline, however, (c) and
+(a) will be moving to the new Hoopl pipeline, however, (c) and
 (d) are only needed by the native backend and will continue to live
 here.
 
@@ -851,14 +879,7 @@ Ideas for other things we could do (put these in Hoopl please!):
 cmmToCmm :: DynFlags -> RawCmmDecl -> (RawCmmDecl, [CLabel])
 cmmToCmm _ top@(CmmData _ _) = (top, [])
 cmmToCmm dflags (CmmProc info lbl (ListGraph blocks)) = runCmmOpt dflags $ do
-  let reachable_blocks | dopt Opt_TryNewCodeGen dflags = blocks
-                       | otherwise = cmmEliminateDeadBlocks blocks
-      -- The new codegen path has already eliminated unreachable blocks by now
-
-      inlined_blocks | dopt Opt_TryNewCodeGen dflags = reachable_blocks
-                     | otherwise = cmmMiniInline dflags reachable_blocks
-
-  blocks' <- mapM cmmBlockConFold inlined_blocks
+  blocks' <- mapM cmmBlockConFold blocks
   return $ CmmProc info lbl (ListGraph blocks')
 
 newtype CmmOptM a = CmmOptM (([CLabel], DynFlags) -> (# a, [CLabel] #))
diff --git a/compiler/nativeGen/Instruction.hs b/compiler/nativeGen/Instruction.hs
index 64ba32c6dc..86f5ae435d 100644
--- a/compiler/nativeGen/Instruction.hs
+++ b/compiler/nativeGen/Instruction.hs
@@ -163,3 +163,16 @@ class   Instruction instr where
                 -> [instr]
 
 
+        -- Subtract an amount from the C stack pointer
+        mkStackAllocInstr
+                :: Platform  -- TODO: remove (needed by x86/x86_64
+                             -- because they share an Instr type)
+                -> Int
+                -> instr
+
+        -- Add an amount to the C stack pointer
+        mkStackDeallocInstr
+                :: Platform  -- TODO: remove (needed by x86/x86_64
+                             -- because they share an Instr type)
+                -> Int
+                -> instr
diff --git a/compiler/nativeGen/PPC/Instr.hs b/compiler/nativeGen/PPC/Instr.hs
index 464a88a08b..1f5e809abb 100644
--- a/compiler/nativeGen/PPC/Instr.hs
+++ b/compiler/nativeGen/PPC/Instr.hs
@@ -64,6 +64,8 @@ instance Instruction Instr where
         mkRegRegMoveInstr _     = ppc_mkRegRegMoveInstr
         takeRegRegMoveInstr     = ppc_takeRegRegMoveInstr
         mkJumpInstr             = ppc_mkJumpInstr
+        mkStackAllocInstr       = panic "no ppc_mkStackAllocInstr"
+        mkStackDeallocInstr     = panic "no ppc_mkStackDeallocInstr"
 
 
 -- -----------------------------------------------------------------------------
diff --git a/compiler/nativeGen/RegAlloc/Graph/Stats.hs b/compiler/nativeGen/RegAlloc/Graph/Stats.hs
index 32970336ad..f85cdb7eff 100644
--- a/compiler/nativeGen/RegAlloc/Graph/Stats.hs
+++ b/compiler/nativeGen/RegAlloc/Graph/Stats.hs
@@ -1,23 +1,16 @@
-{-# OPTIONS -fno-warn-missing-signatures #-}
--- | Carries interesting info for debugging / profiling of the 
---	graph coloring register allocator.
-{-# OPTIONS -fno-warn-tabs #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and
--- detab the module (please do the detabbing in a separate patch). See
---     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
--- for details
+-- | Carries interesting info for debugging / profiling of the
+--      graph coloring register allocator.
 
 module RegAlloc.Graph.Stats (
-	RegAllocStats (..),
+        RegAllocStats (..),
 
-	pprStats,
-	pprStatsSpills,
-	pprStatsLifetimes,
-	pprStatsConflict,
-	pprStatsLifeConflict,
+        pprStats,
+        pprStatsSpills,
+        pprStatsLifetimes,
+        pprStatsConflict,
+        pprStatsLifeConflict,
 
-	countSRMs, addSRM
+        countSRMs, addSRM
 )
 
 where
@@ -45,251 +38,260 @@ import Data.List
 
 data RegAllocStats statics instr
 
-	-- initial graph
-	= RegAllocStatsStart
-	{ raLiveCmm	:: [LiveCmmDecl statics instr]		  	-- ^ initial code, with liveness
-	, raGraph	:: Color.Graph VirtualReg RegClass RealReg   	-- ^ the initial, uncolored graph
-	, raSpillCosts	:: SpillCostInfo } 		 		-- ^ information to help choose which regs to spill
-
-	-- a spill stage
-	| RegAllocStatsSpill
-	{ raCode	:: [LiveCmmDecl statics instr]			-- ^ the code we tried to allocate registers for
-	, raGraph	:: Color.Graph VirtualReg RegClass RealReg	-- ^ the partially colored graph
-	, raCoalesced	:: UniqFM VirtualReg				-- ^ the regs that were coaleced
-	, raSpillStats	:: SpillStats 					-- ^ spiller stats
-	, raSpillCosts	:: SpillCostInfo 				-- ^ number of instrs each reg lives for
-	, raSpilled	:: [LiveCmmDecl statics instr] }			-- ^ code with spill instructions added
-
-	-- a successful coloring
-	| RegAllocStatsColored
-	{ raCode	  :: [LiveCmmDecl statics instr]			-- ^ the code we tried to allocate registers for
-	, raGraph	  :: Color.Graph VirtualReg RegClass RealReg	-- ^ the uncolored graph
-	, raGraphColored  :: Color.Graph VirtualReg RegClass RealReg 	-- ^ the coalesced and colored graph
-	, raCoalesced	  :: UniqFM VirtualReg				-- ^ the regs that were coaleced
-	, raCodeCoalesced :: [LiveCmmDecl statics instr]			-- ^ code with coalescings applied 
-	, raPatched	  :: [LiveCmmDecl statics instr] 		-- ^ code with vregs replaced by hregs
-	, raSpillClean    :: [LiveCmmDecl statics instr]			-- ^ code with unneeded spill\/reloads cleaned out
-	, raFinal	  :: [NatCmmDecl statics instr] 			-- ^ final code
-	, raSRMs	  :: (Int, Int, Int) }				-- ^ spill\/reload\/reg-reg moves present in this code
+        -- initial graph
+        = RegAllocStatsStart
+        { raLiveCmm     :: [LiveCmmDecl statics instr]                  -- ^ initial code, with liveness
+        , raGraph       :: Color.Graph VirtualReg RegClass RealReg      -- ^ the initial, uncolored graph
+        , raSpillCosts  :: SpillCostInfo }                              -- ^ information to help choose which regs to spill
+
+        -- a spill stage
+        | RegAllocStatsSpill
+        { raCode        :: [LiveCmmDecl statics instr]                  -- ^ the code we tried to allocate registers for
+        , raGraph       :: Color.Graph VirtualReg RegClass RealReg      -- ^ the partially colored graph
+        , raCoalesced   :: UniqFM VirtualReg                            -- ^ the regs that were coaleced
+        , raSpillStats  :: SpillStats                                   -- ^ spiller stats
+        , raSpillCosts  :: SpillCostInfo                                -- ^ number of instrs each reg lives for
+        , raSpilled     :: [LiveCmmDecl statics instr] }                -- ^ code with spill instructions added
+
+        -- a successful coloring
+        | RegAllocStatsColored
+        { raCode          :: [LiveCmmDecl statics instr]                -- ^ the code we tried to allocate registers for
+        , raGraph         :: Color.Graph VirtualReg RegClass RealReg    -- ^ the uncolored graph
+        , raGraphColored  :: Color.Graph VirtualReg RegClass RealReg    -- ^ the coalesced and colored graph
+        , raCoalesced     :: UniqFM VirtualReg                          -- ^ the regs that were coaleced
+        , raCodeCoalesced :: [LiveCmmDecl statics instr]                -- ^ code with coalescings applied
+        , raPatched       :: [LiveCmmDecl statics instr]                -- ^ code with vregs replaced by hregs
+        , raSpillClean    :: [LiveCmmDecl statics instr]                -- ^ code with unneeded spill\/reloads cleaned out
+        , raFinal         :: [NatCmmDecl statics instr]                 -- ^ final code
+        , raSRMs          :: (Int, Int, Int) }                          -- ^ spill\/reload\/reg-reg moves present in this code
 
 instance (Outputable statics, Outputable instr) => Outputable (RegAllocStats statics instr) where
 
  ppr (s@RegAllocStatsStart{}) = sdocWithPlatform $ \platform ->
- 	   text "#  Start"
-	$$ text "#  Native code with liveness information."
-	$$ ppr (raLiveCmm s)
-	$$ text ""
-	$$ text "#  Initial register conflict graph."
-	$$ Color.dotGraph 
-		(targetRegDotColor platform)
-		(trivColorable platform
-			(targetVirtualRegSqueeze platform)
-			(targetRealRegSqueeze platform))
-		(raGraph s)
+           text "#  Start"
+        $$ text "#  Native code with liveness information."
+        $$ ppr (raLiveCmm s)
+        $$ text ""
+        $$ text "#  Initial register conflict graph."
+        $$ Color.dotGraph
+                (targetRegDotColor platform)
+                (trivColorable platform
+                        (targetVirtualRegSqueeze platform)
+                        (targetRealRegSqueeze platform))
+                (raGraph s)
 
 
  ppr (s@RegAllocStatsSpill{}) =
- 	   text "#  Spill"
+           text "#  Spill"
 
-	$$ text "#  Code with liveness information."
-	$$ ppr (raCode s)
-	$$ text ""
+        $$ text "#  Code with liveness information."
+        $$ ppr (raCode s)
+        $$ text ""
 
-	$$ (if (not $ isNullUFM $ raCoalesced s)
-		then 	text "#  Registers coalesced."
-			$$ (vcat $ map ppr $ ufmToList $ raCoalesced s)
-			$$ text ""
-		else empty)
+        $$ (if (not $ isNullUFM $ raCoalesced s)
+                then    text "#  Registers coalesced."
+                        $$ (vcat $ map ppr $ ufmToList $ raCoalesced s)
+                        $$ text ""
+                else empty)
 
-	$$ text "#  Spills inserted."
-	$$ ppr (raSpillStats s)
-	$$ text ""
+        $$ text "#  Spills inserted."
+        $$ ppr (raSpillStats s)
+        $$ text ""
 
-	$$ text "#  Code with spills inserted."
-	$$ ppr (raSpilled s)
+        $$ text "#  Code with spills inserted."
+        $$ ppr (raSpilled s)
 
 
  ppr (s@RegAllocStatsColored { raSRMs = (spills, reloads, moves) }) = sdocWithPlatform $ \platform ->
- 	   text "#  Colored"
-
-	$$ text "#  Code with liveness information."
-	$$ ppr (raCode s)
-	$$ text ""
-
-	$$ text "#  Register conflict graph (colored)."
-	$$ Color.dotGraph 
-		(targetRegDotColor platform)
-		(trivColorable platform
-			(targetVirtualRegSqueeze platform)
-			(targetRealRegSqueeze platform))
-		(raGraphColored s)
-	$$ text ""
-
-	$$ (if (not $ isNullUFM $ raCoalesced s)
-		then 	text "#  Registers coalesced."
-			$$ (vcat $ map ppr $ ufmToList $ raCoalesced s)
-			$$ text ""
-		else empty)
-
-	$$ text "#  Native code after coalescings applied."
-	$$ ppr (raCodeCoalesced s)
-	$$ text ""
-
-	$$ text "#  Native code after register allocation."
-	$$ ppr (raPatched s)
-	$$ text ""
-
-	$$ text "#  Clean out unneeded spill/reloads."
-	$$ ppr (raSpillClean s)
-	$$ text ""
-
-	$$ text "#  Final code, after rewriting spill/rewrite pseudo instrs."
-	$$ ppr (raFinal s)
-	$$ text ""
-	$$  text "#  Score:"
-	$$ (text "#          spills  inserted: " <> int spills)
-	$$ (text "#          reloads inserted: " <> int reloads)
-	$$ (text "#   reg-reg moves remaining: " <> int moves)
-	$$ text ""
+           text "#  Colored"
+
+        $$ text "#  Code with liveness information."
+        $$ ppr (raCode s)
+        $$ text ""
+
+        $$ text "#  Register conflict graph (colored)."
+        $$ Color.dotGraph
+                (targetRegDotColor platform)
+                (trivColorable platform
+                        (targetVirtualRegSqueeze platform)
+                        (targetRealRegSqueeze platform))
+                (raGraphColored s)
+        $$ text ""
+
+        $$ (if (not $ isNullUFM $ raCoalesced s)
+                then    text "#  Registers coalesced."
+                        $$ (vcat $ map ppr $ ufmToList $ raCoalesced s)
+                        $$ text ""
+                else empty)
+
+        $$ text "#  Native code after coalescings applied."
+        $$ ppr (raCodeCoalesced s)
+        $$ text ""
+
+        $$ text "#  Native code after register allocation."
+        $$ ppr (raPatched s)
+        $$ text ""
+
+        $$ text "#  Clean out unneeded spill/reloads."
+        $$ ppr (raSpillClean s)
+        $$ text ""
+
+        $$ text "#  Final code, after rewriting spill/rewrite pseudo instrs."
+        $$ ppr (raFinal s)
+        $$ text ""
+        $$  text "#  Score:"
+        $$ (text "#          spills  inserted: " <> int spills)
+        $$ (text "#          reloads inserted: " <> int reloads)
+        $$ (text "#   reg-reg moves remaining: " <> int moves)
+        $$ text ""
 
 -- | Do all the different analysis on this list of RegAllocStats
-pprStats 
-	:: [RegAllocStats statics instr] 
-	-> Color.Graph VirtualReg RegClass RealReg 
-	-> SDoc
-	
+pprStats
+        :: [RegAllocStats statics instr]
+        -> Color.Graph VirtualReg RegClass RealReg
+        -> SDoc
+
 pprStats stats graph
- = let 	outSpills	= pprStatsSpills    stats
-	outLife		= pprStatsLifetimes stats
-	outConflict	= pprStatsConflict  stats
-	outScatter	= pprStatsLifeConflict stats graph
+ = let  outSpills       = pprStatsSpills    stats
+        outLife         = pprStatsLifetimes stats
+        outConflict     = pprStatsConflict  stats
+        outScatter      = pprStatsLifeConflict stats graph
 
-  in	vcat [outSpills, outLife, outConflict, outScatter]
+  in    vcat [outSpills, outLife, outConflict, outScatter]
 
 
 -- | Dump a table of how many spill loads \/ stores were inserted for each vreg.
 pprStatsSpills
-	:: [RegAllocStats statics instr] -> SDoc
+        :: [RegAllocStats statics instr] -> SDoc
 
 pprStatsSpills stats
  = let
-	finals	= [ s	| s@RegAllocStatsColored{} <- stats]
+        finals  = [ s   | s@RegAllocStatsColored{} <- stats]
 
-	-- sum up how many stores\/loads\/reg-reg-moves were left in the code
-	total	= foldl' addSRM (0, 0, 0)
-		$ map raSRMs finals
+        -- sum up how many stores\/loads\/reg-reg-moves were left in the code
+        total   = foldl' addSRM (0, 0, 0)
+                $ map raSRMs finals
 
-    in	(  text "-- spills-added-total"
-	$$ text "--    (stores, loads, reg_reg_moves_remaining)"
-	$$ ppr total
-	$$ text "")
+    in  (  text "-- spills-added-total"
+        $$ text "--    (stores, loads, reg_reg_moves_remaining)"
+        $$ ppr total
+        $$ text "")
 
 
 -- | Dump a table of how long vregs tend to live for in the initial code.
 pprStatsLifetimes
-	:: [RegAllocStats statics instr] -> SDoc
+        :: [RegAllocStats statics instr] -> SDoc
 
 pprStatsLifetimes stats
- = let	info		= foldl' plusSpillCostInfo zeroSpillCostInfo
- 				[ raSpillCosts s
-					| s@RegAllocStatsStart{} <- stats ]
+ = let  info            = foldl' plusSpillCostInfo zeroSpillCostInfo
+                                [ raSpillCosts s
+                                        | s@RegAllocStatsStart{} <- stats ]
 
-	lifeBins	= binLifetimeCount $ lifeMapFromSpillCostInfo info
+        lifeBins        = binLifetimeCount $ lifeMapFromSpillCostInfo info
 
-   in	(  text "-- vreg-population-lifetimes"
-	$$ text "--   (instruction_count, number_of_vregs_that_lived_that_long)"
-	$$ (vcat $ map ppr $ eltsUFM lifeBins)
-	$$ text "\n")
+   in   (  text "-- vreg-population-lifetimes"
+        $$ text "--   (instruction_count, number_of_vregs_that_lived_that_long)"
+        $$ (vcat $ map ppr $ eltsUFM lifeBins)
+        $$ text "\n")
 
 binLifetimeCount :: UniqFM (VirtualReg, Int) -> UniqFM (Int, Int)
 binLifetimeCount fm
- = let	lifes	= map (\l -> (l, (l, 1)))
- 		$ map snd
-		$ eltsUFM fm
+ = let  lifes   = map (\l -> (l, (l, 1)))
+                $ map snd
+                $ eltsUFM fm
 
-   in	addListToUFM_C
-		(\(l1, c1) (_, c2) -> (l1, c1 + c2))
-		emptyUFM
-		lifes
+   in   addListToUFM_C
+                (\(l1, c1) (_, c2) -> (l1, c1 + c2))
+                emptyUFM
+                lifes
 
 
 -- | Dump a table of how many conflicts vregs tend to have in the initial code.
 pprStatsConflict
-	:: [RegAllocStats statics instr] -> SDoc
+        :: [RegAllocStats statics instr] -> SDoc
 
 pprStatsConflict stats
- = let	confMap	= foldl' (plusUFM_C (\(c1, n1) (_, n2) -> (c1, n1 + n2)))
-			emptyUFM
-		$ map Color.slurpNodeConflictCount
-			[ raGraph s | s@RegAllocStatsStart{} <- stats ]
+ = let  confMap = foldl' (plusUFM_C (\(c1, n1) (_, n2) -> (c1, n1 + n2)))
+                        emptyUFM
+                $ map Color.slurpNodeConflictCount
+                        [ raGraph s | s@RegAllocStatsStart{} <- stats ]
 
-   in	(  text "-- vreg-conflicts"
-	$$ text "--   (conflict_count, number_of_vregs_that_had_that_many_conflicts)"
-	$$ (vcat $ map ppr $ eltsUFM confMap)
-	$$ text "\n")
+   in   (  text "-- vreg-conflicts"
+        $$ text "--   (conflict_count, number_of_vregs_that_had_that_many_conflicts)"
+        $$ (vcat $ map ppr $ eltsUFM confMap)
+        $$ text "\n")
 
 
 -- | For every vreg, dump it's how many conflicts it has and its lifetime
---	good for making a scatter plot.
+--      good for making a scatter plot.
 pprStatsLifeConflict
-	:: [RegAllocStats statics instr]
-	-> Color.Graph VirtualReg RegClass RealReg 	-- ^ global register conflict graph
-	-> SDoc
+        :: [RegAllocStats statics instr]
+        -> Color.Graph VirtualReg RegClass RealReg      -- ^ global register conflict graph
+        -> SDoc
 
 pprStatsLifeConflict stats graph
- = let	lifeMap	= lifeMapFromSpillCostInfo
- 		$ foldl' plusSpillCostInfo zeroSpillCostInfo
-		$ [ raSpillCosts s | s@RegAllocStatsStart{} <- stats ]
-
- 	scatter	= map	(\r ->  let lifetime	= case lookupUFM lifeMap r of
-							Just (_, l)	-> l
-							Nothing		-> 0
-				    Just node	= Color.lookupNode graph r
-				in parens $ hcat $ punctuate (text ", ")
-					[ doubleQuotes $ ppr $ Color.nodeId node
-					, ppr $ sizeUniqSet (Color.nodeConflicts node)
-					, ppr $ lifetime ])
-		$ map Color.nodeId
-		$ eltsUFM
-		$ Color.graphMap graph
-
-   in 	(  text "-- vreg-conflict-lifetime"
-	$$ text "--   (vreg, vreg_conflicts, vreg_lifetime)"
-	$$ (vcat scatter)
-	$$ text "\n")
+ = let  lifeMap = lifeMapFromSpillCostInfo
+                $ foldl' plusSpillCostInfo zeroSpillCostInfo
+                $ [ raSpillCosts s | s@RegAllocStatsStart{} <- stats ]
+
+        scatter = map   (\r ->  let lifetime    = case lookupUFM lifeMap r of
+                                                        Just (_, l)     -> l
+                                                        Nothing         -> 0
+                                    Just node   = Color.lookupNode graph r
+                                in parens $ hcat $ punctuate (text ", ")
+                                        [ doubleQuotes $ ppr $ Color.nodeId node
+                                        , ppr $ sizeUniqSet (Color.nodeConflicts node)
+                                        , ppr $ lifetime ])
+                $ map Color.nodeId
+                $ eltsUFM
+                $ Color.graphMap graph
+
+   in   (  text "-- vreg-conflict-lifetime"
+        $$ text "--   (vreg, vreg_conflicts, vreg_lifetime)"
+        $$ (vcat scatter)
+        $$ text "\n")
 
 
 -- | Count spill/reload/reg-reg moves.
---	Lets us see how well the register allocator has done.
-countSRMs 
-	:: Instruction instr
-	=> LiveCmmDecl statics instr -> (Int, Int, Int)
+--      Lets us see how well the register allocator has done.
+countSRMs
+        :: Instruction instr
+        => LiveCmmDecl statics instr -> (Int, Int, Int)
 
 countSRMs cmm
-	= execState (mapBlockTopM countSRM_block cmm) (0, 0, 0)
+        = execState (mapBlockTopM countSRM_block cmm) (0, 0, 0)
 
+countSRM_block :: Instruction instr
+               => GenBasicBlock (LiveInstr instr)
+               -> State (Int, Int, Int) (GenBasicBlock (LiveInstr instr))
 countSRM_block (BasicBlock i instrs)
- = do	instrs'	<- mapM countSRM_instr instrs
- 	return	$ BasicBlock i instrs'
+ = do   instrs' <- mapM countSRM_instr instrs
+        return  $ BasicBlock i instrs'
 
+countSRM_instr :: Instruction instr
+               => LiveInstr instr -> State (Int, Int, Int) (LiveInstr instr)
 countSRM_instr li
-	| LiveInstr SPILL{} _	 <- li
-	= do	modify  $ \(s, r, m)	-> (s + 1, r, m)
-		return li
-
-	| LiveInstr RELOAD{} _ 	<- li
-	= do	modify  $ \(s, r, m)	-> (s, r + 1, m)
-		return li
-	
-	| LiveInstr instr _	<- li
-	, Just _	<- takeRegRegMoveInstr instr
-	= do	modify	$ \(s, r, m)	-> (s, r, m + 1)
-		return li
-
-	| otherwise
-	=	return li
+        | LiveInstr SPILL{} _    <- li
+        = do    modify  $ \(s, r, m)    -> (s + 1, r, m)
+                return li
+
+        | LiveInstr RELOAD{} _  <- li
+        = do    modify  $ \(s, r, m)    -> (s, r + 1, m)
+                return li
+
+        | LiveInstr instr _     <- li
+        , Just _        <- takeRegRegMoveInstr instr
+        = do    modify  $ \(s, r, m)    -> (s, r, m + 1)
+                return li
+
+        | otherwise
+        =       return li
 
 -- sigh..
+addSRM :: (Int, Int, Int) -> (Int, Int, Int) -> (Int, Int, Int)
 addSRM (s1, r1, m1) (s2, r2, m2)
-	= (s1+s2, r1+r2, m1+m2)
+        = let !s = s1 + s2
+              !r = r1 + r2
+              !m = m1 + m2
+          in (s, r, m)
 
diff --git a/compiler/nativeGen/RegAlloc/Linear/Main.hs b/compiler/nativeGen/RegAlloc/Linear/Main.hs
index 3f92ed975b..a15bca07e7 100644
--- a/compiler/nativeGen/RegAlloc/Linear/Main.hs
+++ b/compiler/nativeGen/RegAlloc/Linear/Main.hs
@@ -139,22 +139,27 @@ regAlloc
         :: (Outputable instr, Instruction instr)
         => DynFlags
         -> LiveCmmDecl statics instr
-        -> UniqSM (NatCmmDecl statics instr, Maybe RegAllocStats)
+        -> UniqSM ( NatCmmDecl statics instr
+                  , Maybe Int  -- number of extra stack slots required,
+                               -- beyond maxSpillSlots
+                  , Maybe RegAllocStats)
 
 regAlloc _ (CmmData sec d)
         = return
                 ( CmmData sec d
+                , Nothing
                 , Nothing )
 
 regAlloc _ (CmmProc (LiveInfo info _ _ _) lbl [])
         = return ( CmmProc info lbl (ListGraph [])
+                 , Nothing
                  , Nothing )
 
 regAlloc dflags (CmmProc static lbl sccs)
         | LiveInfo info (Just first_id) (Just block_live) _     <- static
         = do
                 -- do register allocation on each component.
-                (final_blocks, stats)
+                (final_blocks, stats, stack_use)
                         <- linearRegAlloc dflags first_id block_live sccs
 
                 -- make sure the block that was first in the input list
@@ -162,7 +167,15 @@ regAlloc dflags (CmmProc static lbl sccs)
                 let ((first':_), rest')
                                 = partition ((== first_id) . blockId) final_blocks
 
+                let max_spill_slots = maxSpillSlots dflags
+                    extra_stack
+                      | stack_use > max_spill_slots
+                      = Just (stack_use - max_spill_slots)
+                      | otherwise
+                      = Nothing
+
                 return  ( CmmProc info lbl (ListGraph (first' : rest'))
+                        , extra_stack
                         , Just stats)
 
 -- bogus. to make non-exhaustive match warning go away.
@@ -184,7 +197,7 @@ linearRegAlloc
         -> BlockId                      -- ^ the first block
         -> BlockMap RegSet              -- ^ live regs on entry to each basic block
         -> [SCC (LiveBasicBlock instr)] -- ^ instructions annotated with "deaths"
-        -> UniqSM ([NatBasicBlock instr], RegAllocStats)
+        -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int)
 
 linearRegAlloc dflags first_id block_live sccs
  = let platform = targetPlatform dflags
@@ -204,14 +217,14 @@ linearRegAlloc'
         -> BlockId                      -- ^ the first block
         -> BlockMap RegSet              -- ^ live regs on entry to each basic block
         -> [SCC (LiveBasicBlock instr)] -- ^ instructions annotated with "deaths"
-        -> UniqSM ([NatBasicBlock instr], RegAllocStats)
+        -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int)
 
 linearRegAlloc' dflags initFreeRegs first_id block_live sccs
  = do   us      <- getUs
-        let (_, _, stats, blocks) =
+        let (_, stack, stats, blocks) =
                 runR dflags emptyBlockMap initFreeRegs emptyRegMap (emptyStackMap dflags) us
                     $ linearRA_SCCs first_id block_live [] sccs
-        return  (blocks, stats)
+        return  (blocks, stats, getStackUse stack)
 
 
 linearRA_SCCs :: (FR freeRegs, Instruction instr, Outputable instr)
diff --git a/compiler/nativeGen/RegAlloc/Linear/StackMap.hs b/compiler/nativeGen/RegAlloc/Linear/StackMap.hs
index b1fc3c169e..69cf411751 100644
--- a/compiler/nativeGen/RegAlloc/Linear/StackMap.hs
+++ b/compiler/nativeGen/RegAlloc/Linear/StackMap.hs
@@ -21,15 +21,13 @@ module RegAlloc.Linear.StackMap (
 	StackSlot,
 	StackMap(..),
 	emptyStackMap,
-	getStackSlotFor
+        getStackSlotFor,
+        getStackUse
 )
 
 where
 
-import RegAlloc.Linear.FreeRegs
-
 import DynFlags
-import Outputable
 import UniqFM
 import Unique
 
@@ -40,7 +38,7 @@ type StackSlot = Int
 data StackMap 
 	= StackMap 
 	{ -- | The slots that are still available to be allocated.
-	  stackMapFreeSlots	:: [StackSlot]
+          stackMapNextFreeSlot  :: !Int
 
 	  -- | Assignment of vregs to stack slots.
 	, stackMapAssignment	:: UniqFM StackSlot }
@@ -48,7 +46,7 @@ data StackMap
 
 -- | An empty stack map, with all slots available.
 emptyStackMap :: DynFlags -> StackMap
-emptyStackMap dflags = StackMap [0 .. maxSpillSlots dflags] emptyUFM
+emptyStackMap _ = StackMap 0 emptyUFM
 
 
 -- | If this vreg unique already has a stack assignment then return the slot number,
@@ -56,24 +54,13 @@ emptyStackMap dflags = StackMap [0 .. maxSpillSlots dflags] emptyUFM
 --
 getStackSlotFor :: StackMap -> Unique -> (StackMap, Int)
 
-getStackSlotFor (StackMap [] _) _
-
-        -- This happens all the time when trying to compile darcs' SHA1.hs, see Track #1993
-	--	SHA1.lhs has also been added to the Crypto library on Hackage,
-	--	so we see this all the time.  
-	--
-	-- It would be better to automatically invoke the graph allocator, or do something
-	--	else besides panicing, but that's a job for a different day.  -- BL 2009/02
-	--
-	= panic $   "RegAllocLinear.getStackSlotFor: out of stack slots\n"
-		++  "   If you are trying to compile SHA1.hs from the crypto library then this\n"
-		++  "   is a known limitation in the linear allocator.\n"
-		++  "\n"
-		++  "   Try enabling the graph colouring allocator with -fregs-graph instead."
-		++  "   You can still file a bug report if you like.\n"
-		
-getStackSlotFor fs@(StackMap (freeSlot:stack') reserved) reg =
-    case lookupUFM reserved reg of
-    	Just slot	-> (fs, slot)
-    	Nothing		-> (StackMap stack' (addToUFM reserved reg freeSlot), freeSlot)
+getStackSlotFor fs@(StackMap _ reserved) reg
+  | Just slot <- lookupUFM reserved reg  =  (fs, slot)
+
+getStackSlotFor (StackMap freeSlot reserved) reg =
+    (StackMap (freeSlot+1) (addToUFM reserved reg freeSlot), freeSlot)
+
+-- | Return the number of stack slots that were allocated
+getStackUse :: StackMap -> Int
+getStackUse (StackMap freeSlot _) = freeSlot
 
diff --git a/compiler/nativeGen/RegAlloc/Liveness.hs b/compiler/nativeGen/RegAlloc/Liveness.hs
index ac58944f1c..608f0a423b 100644
--- a/compiler/nativeGen/RegAlloc/Liveness.hs
+++ b/compiler/nativeGen/RegAlloc/Liveness.hs
@@ -5,8 +5,6 @@
 -- (c) The University of Glasgow 2004
 --
 -----------------------------------------------------------------------------
-{-# OPTIONS -Wall -fno-warn-name-shadowing #-}
-
 module RegAlloc.Liveness (
         RegSet,
         RegMap, emptyRegMap,
@@ -138,6 +136,11 @@ instance Instruction instr => Instruction (InstrSR instr) where
 
         mkJumpInstr target      = map Instr (mkJumpInstr target)
 
+        mkStackAllocInstr platform amount =
+             Instr (mkStackAllocInstr platform amount)
+
+        mkStackDeallocInstr platform amount =
+             Instr (mkStackDeallocInstr platform amount)
 
 
 -- | An instruction with liveness information.
diff --git a/compiler/nativeGen/SPARC/Instr.hs b/compiler/nativeGen/SPARC/Instr.hs
index 9404badea6..f55c660118 100644
--- a/compiler/nativeGen/SPARC/Instr.hs
+++ b/compiler/nativeGen/SPARC/Instr.hs
@@ -108,6 +108,8 @@ instance Instruction Instr where
 	mkRegRegMoveInstr	= sparc_mkRegRegMoveInstr
 	takeRegRegMoveInstr	= sparc_takeRegRegMoveInstr
 	mkJumpInstr		= sparc_mkJumpInstr
+        mkStackAllocInstr       = panic "no sparc_mkStackAllocInstr"
+        mkStackDeallocInstr     = panic "no sparc_mkStackDeallocInstr"
 
 
 -- | SPARC instruction set.
diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs
index b83ede89aa..fbbc37e6c9 100644
--- a/compiler/nativeGen/X86/CodeGen.hs
+++ b/compiler/nativeGen/X86/CodeGen.hs
@@ -1214,22 +1214,22 @@ getCondCode (CmmMachOp mop [x, y])
       MO_F_Lt W64 -> condFltCode LTT x y
       MO_F_Le W64 -> condFltCode LE  x y
 
-      MO_Eq _ -> condIntCode EQQ x y
-      MO_Ne _ -> condIntCode NE  x y
+      MO_Eq _     -> condIntCode EQQ x y
+      MO_Ne _     -> condIntCode NE  x y
 
-      MO_S_Gt _ -> condIntCode GTT x y
-      MO_S_Ge _ -> condIntCode GE  x y
-      MO_S_Lt _ -> condIntCode LTT x y
-      MO_S_Le _ -> condIntCode LE  x y
+      MO_S_Gt _   -> condIntCode GTT x y
+      MO_S_Ge _   -> condIntCode GE  x y
+      MO_S_Lt _   -> condIntCode LTT x y
+      MO_S_Le _   -> condIntCode LE  x y
 
       MO_U_Gt _ -> condIntCode GU  x y
       MO_U_Ge _ -> condIntCode GEU x y
       MO_U_Lt _ -> condIntCode LU  x y
       MO_U_Le _ -> condIntCode LEU x y
 
-      _other -> pprPanic "getCondCode(x86,x86_64,sparc)" (ppr (CmmMachOp mop [x,y]))
+      _other -> pprPanic "getCondCode(x86,x86_64)" (ppr (CmmMachOp mop [x,y]))
 
-getCondCode other = pprPanic "getCondCode(2)(x86,sparc)" (ppr other)
+getCondCode other = pprPanic "getCondCode(2)(x86,x86_64)" (ppr other)
 
 
 
@@ -1276,7 +1276,8 @@ condIntCode' _ cond x (CmmLit (CmmInt 0 pk)) = do
     return (CondCode False cond code)
 
 -- anything vs operand
-condIntCode' is32Bit cond x y | isOperand is32Bit y = do
+condIntCode' is32Bit cond x y
+ | isOperand is32Bit y = do
     dflags <- getDynFlags
     (x_reg, x_code) <- getNonClobberedReg x
     (y_op,  y_code) <- getOperand y
@@ -1284,6 +1285,17 @@ condIntCode' is32Bit cond x y | isOperand is32Bit y = do
         code = x_code `appOL` y_code `snocOL`
                   CMP (cmmTypeSize (cmmExprType dflags x)) y_op (OpReg x_reg)
     return (CondCode False cond code)
+-- operand vs. anything: invert the comparison so that we can use a
+-- single comparison instruction.
+ | isOperand is32Bit x
+ , Just revcond <- maybeFlipCond cond = do
+    dflags <- getDynFlags
+    (y_reg, y_code) <- getNonClobberedReg y
+    (x_op,  x_code) <- getOperand x
+    let
+        code = y_code `appOL` x_code `snocOL`
+                  CMP (cmmTypeSize (cmmExprType dflags x)) x_op (OpReg y_reg)
+    return (CondCode False revcond code)
 
 -- anything vs anything
 condIntCode' _ cond x y = do
diff --git a/compiler/nativeGen/X86/Cond.hs b/compiler/nativeGen/X86/Cond.hs
index ce97095222..586dabd8f4 100644
--- a/compiler/nativeGen/X86/Cond.hs
+++ b/compiler/nativeGen/X86/Cond.hs
@@ -1,39 +1,32 @@
-
-{-# OPTIONS -fno-warn-tabs #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and
--- detab the module (please do the detabbing in a separate patch). See
---     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
--- for details
-
 module X86.Cond (
-	Cond(..),
-	condUnsigned,
-	condToSigned,
-	condToUnsigned
+        Cond(..),
+        condUnsigned,
+        condToSigned,
+        condToUnsigned,
+        maybeFlipCond
 )
 
 where
 
 data Cond
-	= ALWAYS	-- What's really used? ToDo
-	| EQQ
-	| GE
-	| GEU
-	| GTT
-	| GU
-	| LE
-	| LEU
-	| LTT
-	| LU
-	| NE
-	| NEG
-	| POS
-	| CARRY
-	| OFLO
-	| PARITY
-	| NOTPARITY
-	deriving Eq
+        = ALWAYS        -- What's really used? ToDo
+        | EQQ
+        | GE
+        | GEU
+        | GTT
+        | GU
+        | LE
+        | LEU
+        | LTT
+        | LU
+        | NE
+        | NEG
+        | POS
+        | CARRY
+        | OFLO
+        | PARITY
+        | NOTPARITY
+        deriving Eq
 
 condUnsigned :: Cond -> Bool
 condUnsigned GU  = True
@@ -57,3 +50,19 @@ condToUnsigned LTT = LU
 condToUnsigned GE  = GEU
 condToUnsigned LE  = LEU
 condToUnsigned x   = x
+
+-- | @maybeFlipCond c@ returns @Just c'@ if it is possible to flip the
+-- arguments to the conditional @c@, and the new condition should be @c'@.
+maybeFlipCond :: Cond -> Maybe Cond
+maybeFlipCond cond  = case cond of
+        EQQ   -> Just EQQ
+        NE    -> Just NE
+        LU    -> Just GU
+        GU    -> Just LU
+        LEU   -> Just GEU
+        GEU   -> Just LEU
+        LTT   -> Just GTT
+        GTT   -> Just LTT
+        LE    -> Just GE
+        GE    -> Just LE
+        _other -> Nothing
diff --git a/compiler/nativeGen/X86/Instr.hs b/compiler/nativeGen/X86/Instr.hs
index 7f0e48e769..7bd9b0cc9e 100644
--- a/compiler/nativeGen/X86/Instr.hs
+++ b/compiler/nativeGen/X86/Instr.hs
@@ -11,7 +11,7 @@
 
 module X86.Instr (Instr(..), Operand(..),
                   getJumpDestBlockId, canShortcut, shortcutStatics,
-                  shortcutJump, i386_insert_ffrees,
+                  shortcutJump, i386_insert_ffrees, allocMoreStack,
                   maxSpillSlots, archWordSize)
 where
 
@@ -58,6 +58,8 @@ instance Instruction Instr where
         mkRegRegMoveInstr       = x86_mkRegRegMoveInstr
         takeRegRegMoveInstr     = x86_takeRegRegMoveInstr
         mkJumpInstr             = x86_mkJumpInstr
+        mkStackAllocInstr       = x86_mkStackAllocInstr
+        mkStackDeallocInstr     = x86_mkStackDeallocInstr
 
 
 -- -----------------------------------------------------------------------------
@@ -620,14 +622,13 @@ x86_mkSpillInstr
     -> Instr
 
 x86_mkSpillInstr dflags reg delta slot
-  = let off     = spillSlotToOffset dflags slot
+  = let off     = spillSlotToOffset dflags slot - delta
     in
-    let off_w = (off - delta) `div` (if is32Bit then 4 else 8)
-    in case targetClassOfReg platform reg of
+    case targetClassOfReg platform reg of
            RcInteger   -> MOV (archWordSize is32Bit)
-                              (OpReg reg) (OpAddr (spRel dflags off_w))
-           RcDouble    -> GST FF80 reg (spRel dflags off_w) {- RcFloat/RcDouble -}
-           RcDoubleSSE -> MOV FF64 (OpReg reg) (OpAddr (spRel dflags off_w))
+                              (OpReg reg) (OpAddr (spRel dflags off))
+           RcDouble    -> GST FF80 reg (spRel dflags off) {- RcFloat/RcDouble -}
+           RcDoubleSSE -> MOV FF64 (OpReg reg) (OpAddr (spRel dflags off))
            _         -> panic "X86.mkSpillInstr: no match"
     where platform = targetPlatform dflags
           is32Bit = target32Bit platform
@@ -641,14 +642,13 @@ x86_mkLoadInstr
     -> Instr
 
 x86_mkLoadInstr dflags reg delta slot
-  = let off     = spillSlotToOffset dflags slot
+  = let off     = spillSlotToOffset dflags slot - delta
     in
-        let off_w = (off-delta) `div` (if is32Bit then 4 else 8)
-        in case targetClassOfReg platform reg of
+        case targetClassOfReg platform reg of
               RcInteger -> MOV (archWordSize is32Bit)
-                               (OpAddr (spRel dflags off_w)) (OpReg reg)
-              RcDouble  -> GLD FF80 (spRel dflags off_w) reg {- RcFloat/RcDouble -}
-              RcDoubleSSE -> MOV FF64 (OpAddr (spRel dflags off_w)) (OpReg reg)
+                               (OpAddr (spRel dflags off)) (OpReg reg)
+              RcDouble  -> GLD FF80 (spRel dflags off) reg {- RcFloat/RcDouble -}
+              RcDoubleSSE -> MOV FF64 (OpAddr (spRel dflags off)) (OpReg reg)
               _           -> panic "X86.x86_mkLoadInstr"
     where platform = targetPlatform dflags
           is32Bit = target32Bit platform
@@ -666,12 +666,7 @@ maxSpillSlots dflags
 -- the C stack pointer.
 spillSlotToOffset :: DynFlags -> Int -> Int
 spillSlotToOffset dflags slot
-   | slot >= 0 && slot < maxSpillSlots dflags
    = 64 + spillSlotSize dflags * slot
-   | otherwise
-   = pprPanic "spillSlotToOffset:"
-              (   text "invalid spill location: " <> int slot
-              $$  text "maxSpillSlots:          " <> int (maxSpillSlots dflags))
 
 --------------------------------------------------------------------------------
 
@@ -744,8 +739,25 @@ x86_mkJumpInstr id
         = [JXX ALWAYS id]
 
 
-
-
+x86_mkStackAllocInstr
+        :: Platform
+        -> Int
+        -> Instr
+x86_mkStackAllocInstr platform amount
+  = case platformArch platform of
+      ArchX86    -> SUB II32 (OpImm (ImmInt amount)) (OpReg esp)
+      ArchX86_64 -> SUB II64 (OpImm (ImmInt amount)) (OpReg rsp)
+      _ -> panic "x86_mkStackAllocInstr"
+
+x86_mkStackDeallocInstr
+        :: Platform
+        -> Int
+        -> Instr
+x86_mkStackDeallocInstr platform amount
+  = case platformArch platform of
+      ArchX86    -> ADD II32 (OpImm (ImmInt amount)) (OpReg esp)
+      ArchX86_64 -> ADD II64 (OpImm (ImmInt amount)) (OpReg rsp)
+      _ -> panic "x86_mkStackDeallocInstr"
 
 i386_insert_ffrees
         :: [GenBasicBlock Instr]
@@ -753,18 +765,12 @@ i386_insert_ffrees
 
 i386_insert_ffrees blocks
    | or (map (any is_G_instr) [ instrs | BasicBlock _ instrs <- blocks ])
-   = map ffree_before_nonlocal_transfers blocks
-
+   = map insertGFREEs blocks
    | otherwise
    = blocks
-  where
-   ffree_before_nonlocal_transfers (BasicBlock id insns)
-     = BasicBlock id (foldr p [] insns)
-     where p insn r = case insn of
-                        CALL _ _ -> GFREE : insn : r
-                        JMP _ _  -> GFREE : insn : r
-                        JXX_GBL _ _ -> panic "i386_insert_ffrees: cannot handle JXX_GBL"
-                        _        -> insn : r
+ where
+   insertGFREEs (BasicBlock id insns)
+     = BasicBlock id (insertBeforeNonlocalTransfers GFREE insns)
 
 -- if you ever add a new FP insn to the fake x86 FP insn set,
 -- you must update this too
@@ -796,6 +802,57 @@ is_G_instr instr
         _               -> False
 
 
+--
+-- Note [extra spill slots]
+--
+-- If the register allocator used more spill slots than we have
+-- pre-allocated (rESERVED_C_STACK_BYTES), then we must allocate more
+-- C stack space on entry and exit from this proc.  Therefore we
+-- insert a "sub $N, %rsp" at every entry point, and an "add $N, %rsp"
+-- before every non-local jump.
+--
+-- This became necessary when the new codegen started bundling entire
+-- functions together into one proc, because the register allocator
+-- assigns a different stack slot to each virtual reg within a proc.
+-- To avoid using so many slots we could also:
+--
+--   - split up the proc into connected components before code generator
+--
+--   - rename the virtual regs, so that we re-use vreg names and hence
+--     stack slots for non-overlapping vregs.
+--
+allocMoreStack
+  :: Platform
+  -> Int
+  -> NatCmmDecl statics X86.Instr.Instr
+  -> NatCmmDecl statics X86.Instr.Instr
+
+allocMoreStack _ _ top@(CmmData _ _) = top
+allocMoreStack platform amount (CmmProc info lbl (ListGraph code)) =
+        CmmProc info lbl (ListGraph (map insert_stack_insns code))
+  where
+    alloc   = mkStackAllocInstr platform amount
+    dealloc = mkStackDeallocInstr platform amount
+
+    is_entry_point id = id `mapMember` info
+
+    insert_stack_insns (BasicBlock id insns)
+       | is_entry_point id  = BasicBlock id (alloc : block')
+       | otherwise          = BasicBlock id block'
+       where
+         block' = insertBeforeNonlocalTransfers dealloc insns
+
+
+insertBeforeNonlocalTransfers :: Instr -> [Instr] -> [Instr]
+insertBeforeNonlocalTransfers insert insns
+     = foldr p [] insns
+     where p insn r = case insn of
+                        CALL _ _    -> insert : insn : r
+                        JMP _ _     -> insert : insn : r
+                        JXX_GBL _ _ -> panic "insertBeforeNonlocalTransfers: cannot handle JXX_GBL"
+                        _           -> insn : r
+
+
 data JumpDest = DestBlockId BlockId | DestImm Imm
 
 getJumpDestBlockId :: JumpDest -> Maybe BlockId
diff --git a/compiler/nativeGen/X86/Regs.hs b/compiler/nativeGen/X86/Regs.hs
index 4eec96f5e1..6b2fe16855 100644
--- a/compiler/nativeGen/X86/Regs.hs
+++ b/compiler/nativeGen/X86/Regs.hs
@@ -196,13 +196,13 @@ addrModeRegs _ = []
 
 
 spRel :: DynFlags
-      -> Int -- ^ desired stack offset in words, positive or negative
+      -> Int -- ^ desired stack offset in bytes, positive or negative
       -> AddrMode
 spRel dflags n
  | target32Bit (targetPlatform dflags)
-    = AddrBaseIndex (EABaseReg esp) EAIndexNone (ImmInt (n * wORD_SIZE dflags))
+    = AddrBaseIndex (EABaseReg esp) EAIndexNone (ImmInt n)
  | otherwise
-    = AddrBaseIndex (EABaseReg rsp) EAIndexNone (ImmInt (n * wORD_SIZE dflags))
+    = AddrBaseIndex (EABaseReg rsp) EAIndexNone (ImmInt n)
 
 -- The register numbers must fit into 32 bits on x86, so that we can
 -- use a Word32 to represent the set of free registers in the register
diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index 91f00ecf2f..aaa4f054ba 100644
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -1869,8 +1869,6 @@ explicitNamespacesBit :: Int
 explicitNamespacesBit = 29
 lambdaCaseBit :: Int
 lambdaCaseBit = 30
-multiWayIfBit :: Int
-multiWayIfBit = 31
 
 
 always :: Int -> Bool
@@ -1926,8 +1924,6 @@ explicitNamespacesEnabled :: Int -> Bool
 explicitNamespacesEnabled flags = testBit flags explicitNamespacesBit
 lambdaCaseEnabled :: Int -> Bool
 lambdaCaseEnabled flags = testBit flags lambdaCaseBit
-multiWayIfEnabled :: Int -> Bool
-multiWayIfEnabled flags = testBit flags multiWayIfBit
 
 -- PState for parsing options pragmas
 --
@@ -1991,7 +1987,6 @@ mkPState flags buf loc =
                .|. typeLiteralsBit             `setBitIf` xopt Opt_DataKinds flags
                .|. explicitNamespacesBit       `setBitIf` xopt Opt_ExplicitNamespaces flags
                .|. lambdaCaseBit               `setBitIf` xopt Opt_LambdaCase               flags
-               .|. multiWayIfBit               `setBitIf` xopt Opt_MultiWayIf               flags
       --
       setBitIf :: Int -> Bool -> Int
       b `setBitIf` cond | cond      = bit b
diff --git a/compiler/prelude/PrelRules.lhs b/compiler/prelude/PrelRules.lhs
index 3f1236599a..aa4156bfdb 100644
--- a/compiler/prelude/PrelRules.lhs
+++ b/compiler/prelude/PrelRules.lhs
@@ -385,37 +385,38 @@ litEq is_eq = msum
 -- minBound, so we can replace such comparison with False.
 boundsCmp :: Comparison -> RuleM CoreExpr
 boundsCmp op = do
+  dflags <- getDynFlags
   [a, b] <- getArgs
-  liftMaybe $ mkRuleFn op a b
+  liftMaybe $ mkRuleFn dflags op a b
 
 data Comparison = Gt | Ge | Lt | Le
 
-mkRuleFn :: Comparison -> CoreExpr -> CoreExpr -> Maybe CoreExpr
-mkRuleFn Gt (Lit lit) _ | isMinBound lit = Just falseVal
-mkRuleFn Le (Lit lit) _ | isMinBound lit = Just trueVal
-mkRuleFn Ge _ (Lit lit) | isMinBound lit = Just trueVal
-mkRuleFn Lt _ (Lit lit) | isMinBound lit = Just falseVal
-mkRuleFn Ge (Lit lit) _ | isMaxBound lit = Just trueVal
-mkRuleFn Lt (Lit lit) _ | isMaxBound lit = Just falseVal
-mkRuleFn Gt _ (Lit lit) | isMaxBound lit = Just falseVal
-mkRuleFn Le _ (Lit lit) | isMaxBound lit = Just trueVal
-mkRuleFn _ _ _                           = Nothing
-
-isMinBound :: Literal -> Bool
-isMinBound (MachChar c)   = c == minBound
-isMinBound (MachInt i)    = i == toInteger (minBound :: Int)
-isMinBound (MachInt64 i)  = i == toInteger (minBound :: Int64)
-isMinBound (MachWord i)   = i == toInteger (minBound :: Word)
-isMinBound (MachWord64 i) = i == toInteger (minBound :: Word64)
-isMinBound _              = False
-
-isMaxBound :: Literal -> Bool
-isMaxBound (MachChar c)   = c == maxBound
-isMaxBound (MachInt i)    = i == toInteger (maxBound :: Int)
-isMaxBound (MachInt64 i)  = i == toInteger (maxBound :: Int64)
-isMaxBound (MachWord i)   = i == toInteger (maxBound :: Word)
-isMaxBound (MachWord64 i) = i == toInteger (maxBound :: Word64)
-isMaxBound _              = False
+mkRuleFn :: DynFlags -> Comparison -> CoreExpr -> CoreExpr -> Maybe CoreExpr
+mkRuleFn dflags Gt (Lit lit) _ | isMinBound dflags lit = Just falseVal
+mkRuleFn dflags Le (Lit lit) _ | isMinBound dflags lit = Just trueVal
+mkRuleFn dflags Ge _ (Lit lit) | isMinBound dflags lit = Just trueVal
+mkRuleFn dflags Lt _ (Lit lit) | isMinBound dflags lit = Just falseVal
+mkRuleFn dflags Ge (Lit lit) _ | isMaxBound dflags lit = Just trueVal
+mkRuleFn dflags Lt (Lit lit) _ | isMaxBound dflags lit = Just falseVal
+mkRuleFn dflags Gt _ (Lit lit) | isMaxBound dflags lit = Just falseVal
+mkRuleFn dflags Le _ (Lit lit) | isMaxBound dflags lit = Just trueVal
+mkRuleFn _ _ _ _                                       = Nothing
+
+isMinBound :: DynFlags -> Literal -> Bool
+isMinBound _      (MachChar c)   = c == minBound
+isMinBound dflags (MachInt i)    = i == tARGET_MIN_INT dflags
+isMinBound _      (MachInt64 i)  = i == toInteger (minBound :: Int64)
+isMinBound _      (MachWord i)   = i == 0
+isMinBound _      (MachWord64 i) = i == 0
+isMinBound _      _              = False
+
+isMaxBound :: DynFlags -> Literal -> Bool
+isMaxBound _      (MachChar c)   = c == maxBound
+isMaxBound dflags (MachInt i)    = i == tARGET_MAX_INT dflags
+isMaxBound _      (MachInt64 i)  = i == toInteger (maxBound :: Int64)
+isMaxBound dflags (MachWord i)   = i == tARGET_MAX_WORD dflags
+isMaxBound _      (MachWord64 i) = i == toInteger (maxBound :: Word64)
+isMaxBound _      _              = False
 
 
 -- Note that we *don't* warn the user about overflow. It's not done at
diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs
index c3fd407ff9..c232a89cd1 100644
--- a/compiler/rename/RnEnv.lhs
+++ b/compiler/rename/RnEnv.lhs
@@ -290,7 +290,11 @@ lookupInstDeclBndr cls what rdr
                 -- In an instance decl you aren't allowed
                 -- to use a qualified name for the method
                 -- (Although it'd make perfect sense.)
-       ; lookupSubBndrOcc (ParentIs cls) doc rdr }
+       ; lookupSubBndrOcc False -- False => we don't give deprecated
+                                -- warnings when a deprecated class
+                                -- method is defined. We only warn
+                                -- when it's used
+                          (ParentIs cls) doc rdr }
   where
     doc = what <+> ptext (sLit "of class") <+> quotes (ppr cls)
 
@@ -337,11 +341,12 @@ lookupConstructorFields con_name
 -- unambiguous because there is only one field id 'fld' in scope.
 -- But currently it's rejected.
 
-lookupSubBndrOcc :: Parent  -- NoParent   => just look it up as usual
+lookupSubBndrOcc :: Bool
+                 -> Parent  -- NoParent   => just look it up as usual
                             -- ParentIs p => use p to disambiguate
                  -> SDoc -> RdrName
                  -> RnM Name
-lookupSubBndrOcc parent doc rdr_name
+lookupSubBndrOcc warnIfDeprec parent doc rdr_name
   | Just n <- isExact_maybe rdr_name   -- This happens in derived code
   = lookupExactOcc n
 
@@ -355,7 +360,7 @@ lookupSubBndrOcc parent doc rdr_name
                 -- NB: lookupGlobalRdrEnv, not lookupGRE_RdrName!
                 --     The latter does pickGREs, but we want to allow 'x'
                 --     even if only 'M.x' is in scope
-            [gre] -> do { addUsedRdrName gre (used_rdr_name gre)
+            [gre] -> do { addUsedRdrName warnIfDeprec gre (used_rdr_name gre)
                           -- Add a usage; this is an *occurrence* site
                         ; return (gre_name gre) }
             []    -> do { addErr (unknownSubordinateErr doc rdr_name)
@@ -690,7 +695,7 @@ lookupGreRn_help rdr_name lookup
   = do  { env <- getGlobalRdrEnv
         ; case lookup env of
             []    -> return Nothing
-            [gre] -> do { addUsedRdrName gre rdr_name
+            [gre] -> do { addUsedRdrName True gre rdr_name
                         ; return (Just gre) }
             gres  -> do { addNameClashErrRn rdr_name gres
                         ; return (Just (head gres)) } }
@@ -719,13 +724,13 @@ Note [Handling of deprecations]
      - the things exported by a module export 'module M'
 
 \begin{code}
-addUsedRdrName :: GlobalRdrElt -> RdrName -> RnM ()
+addUsedRdrName :: Bool -> GlobalRdrElt -> RdrName -> RnM ()
 -- Record usage of imported RdrNames
-addUsedRdrName gre rdr
+addUsedRdrName warnIfDeprec gre rdr
   | isLocalGRE gre = return ()  -- No call to warnIfDeprecated
                                 -- See Note [Handling of deprecations]
   | otherwise      = do { env <- getGblEnv
-                        ; warnIfDeprecated gre
+                        ; when warnIfDeprec $ warnIfDeprecated gre
                         ; updMutVar (tcg_used_rdrnames env)
                                     (\s -> Set.insert rdr s) }
 
diff --git a/compiler/rename/RnPat.lhs b/compiler/rename/RnPat.lhs
index e37860abb7..57f75fb50d 100644
--- a/compiler/rename/RnPat.lhs
+++ b/compiler/rename/RnPat.lhs
@@ -483,7 +483,7 @@ rnHsRecFields1 ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot }
     rn_fld pun_ok parent (HsRecField { hsRecFieldId = fld
                        	      	     , hsRecFieldArg = arg
                        	      	     , hsRecPun = pun })
-      = do { fld'@(L loc fld_nm) <- wrapLocM (lookupSubBndrOcc parent doc) fld
+      = do { fld'@(L loc fld_nm) <- wrapLocM (lookupSubBndrOcc True parent doc) fld
            ; arg' <- if pun 
                      then do { checkErr pun_ok (badPun fld)
                              ; return (L loc (mk_arg (mkRdrUnqual (nameOccName fld_nm)))) }
diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs
index 595f4653d3..e6abf7bd41 100644
--- a/compiler/rename/RnSource.lhs
+++ b/compiler/rename/RnSource.lhs
@@ -4,15 +4,8 @@
 \section[RnSource]{Main pass of renamer}
 
 \begin{code}
-{-# OPTIONS -fno-warn-tabs #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and
--- detab the module (please do the detabbing in a separate patch). See
---     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
--- for details
-
-module RnSource ( 
-	rnSrcDecls, addTcgDUs, rnTyClDecls, findSplice
+module RnSource (
+        rnSrcDecls, addTcgDUs, rnTyClDecls, findSplice
     ) where
 
 #include "HsVersions.h"
@@ -20,10 +13,10 @@ module RnSource (
 import {-# SOURCE #-} RnExpr( rnLExpr )
 #ifdef GHCI
 import {-# SOURCE #-} TcSplice ( runQuasiQuoteDecl )
-#endif 	/* GHCI */
+#endif /* GHCI */
 
 import HsSyn
-import RdrName	
+import RdrName
 import RnTypes
 import RnBinds
 import RnEnv
@@ -31,10 +24,10 @@ import RnNames
 import RnHsDoc          ( rnHsDoc, rnMbLHsDoc )
 import TcRnMonad
 
-import ForeignCall	( CCallTarget(..) )
+import ForeignCall      ( CCallTarget(..) )
 import Module
-import HscTypes		( Warnings(..), plusWarns )
-import Class		( FunDep )
+import HscTypes         ( Warnings(..), plusWarns )
+import Class            ( FunDep )
 import Name
 import NameSet
 import NameEnv
@@ -45,9 +38,9 @@ import BasicTypes       ( RuleName )
 import FastString
 import SrcLoc
 import DynFlags
-import HscTypes		( HscEnv, hsc_dflags )
+import HscTypes         ( HscEnv, hsc_dflags )
 import ListSetOps       ( findDupsEq )
-import Digraph		( SCC, flattenSCC, stronglyConnCompFromEdgedVertices )
+import Digraph          ( SCC, flattenSCC, stronglyConnCompFromEdgedVertices )
 
 import Control.Monad
 import Data.List( partition )
@@ -65,7 +58,7 @@ for undefined tyvars, and tyvars in contexts that are ambiguous.
 since we don't have functional dependency information at this point.)
 \item
 Checks that all variable occurences are defined.
-\item 
+\item
 Checks the @(..)@ etc constraints in the export list.
 \end{enumerate}
 
@@ -142,7 +135,7 @@ rnSrcDecls extra_deps group@(HsGroup { hs_valds   = val_decls,
    traceRn (text "finish rnmono" <+> ppr rn_val_decls) ;
 
    -- (G) Rename Fixity and deprecations
-   
+
    -- Rename fixity declarations and error if we try to
    -- fix something from another module (duplicates were checked in (A))
    rn_fix_decls <- rnSrcFixityDecls all_bndrs fix_decls ;
@@ -168,30 +161,30 @@ rnSrcDecls extra_deps group@(HsGroup { hs_valds   = val_decls,
 
     last_tcg_env <- getGblEnv ;
    -- (I) Compute the results and return
-   let {rn_group = HsGroup { hs_valds  	= rn_val_decls,
-			     hs_tyclds 	= rn_tycl_decls,
-			     hs_instds 	= rn_inst_decls,
+   let {rn_group = HsGroup { hs_valds   = rn_val_decls,
+                             hs_tyclds  = rn_tycl_decls,
+                             hs_instds  = rn_inst_decls,
                              hs_derivds = rn_deriv_decls,
-			     hs_fixds   = rn_fix_decls,
-			     hs_warnds  = [], -- warns are returned in the tcg_env
-	                                     -- (see below) not in the HsGroup
-			     hs_fords  = rn_foreign_decls,
-			     hs_annds  = rn_ann_decls,
-			     hs_defds  = rn_default_decls,
-			     hs_ruleds = rn_rule_decls,
-			     hs_vects  = rn_vect_decls,
+                             hs_fixds   = rn_fix_decls,
+                             hs_warnds  = [], -- warns are returned in the tcg_env
+                                             -- (see below) not in the HsGroup
+                             hs_fords  = rn_foreign_decls,
+                             hs_annds  = rn_ann_decls,
+                             hs_defds  = rn_default_decls,
+                             hs_ruleds = rn_rule_decls,
+                             hs_vects  = rn_vect_decls,
                              hs_docs   = rn_docs } ;
 
         tycl_bndrs = hsTyClDeclsBinders rn_tycl_decls rn_inst_decls ;
         ford_bndrs = hsForeignDeclsBinders rn_foreign_decls ;
-	other_def  = (Just (mkNameSet tycl_bndrs `unionNameSets` mkNameSet ford_bndrs), emptyNameSet) ;
-        other_fvs  = plusFVs [src_fvs1, src_fvs2, src_fvs3, src_fvs4, 
-			      src_fvs5, src_fvs6, src_fvs7, src_fvs8] ;
-		-- It is tiresome to gather the binders from type and class decls
+        other_def  = (Just (mkNameSet tycl_bndrs `unionNameSets` mkNameSet ford_bndrs), emptyNameSet) ;
+        other_fvs  = plusFVs [src_fvs1, src_fvs2, src_fvs3, src_fvs4,
+                              src_fvs5, src_fvs6, src_fvs7, src_fvs8] ;
+                -- It is tiresome to gather the binders from type and class decls
 
-	src_dus = [other_def] `plusDU` bind_dus `plusDU` usesOnly other_fvs ;
-		-- Instance decls may have occurrences of things bound in bind_dus
-		-- so we must put other_fvs last
+        src_dus = [other_def] `plusDU` bind_dus `plusDU` usesOnly other_fvs ;
+                -- Instance decls may have occurrences of things bound in bind_dus
+                -- so we must put other_fvs last
 
         final_tcg_env = let tcg_env' = (last_tcg_env `addTcgDUs` src_dus)
                         in -- we return the deprecs in the env, not in the HsGroup above
@@ -209,8 +202,8 @@ inNewEnv :: TcM TcGblEnv -> (TcGblEnv -> TcM a) -> TcM a
 inNewEnv env cont = do e <- env
                        setGblEnv e $ cont e
 
-addTcgDUs :: TcGblEnv -> DefUses -> TcGblEnv 
--- This function could be defined lower down in the module hierarchy, 
+addTcgDUs :: TcGblEnv -> DefUses -> TcGblEnv
+-- This function could be defined lower down in the module hierarchy,
 -- but there doesn't seem anywhere very logical to put it.
 addTcgDUs tcg_env dus = tcg_env { tcg_dus = tcg_dus tcg_env `plusDU` dus }
 
@@ -220,17 +213,17 @@ rnList f xs = mapFvRn (wrapLocFstM f) xs
 
 
 %*********************************************************
-%*						 	 *
-	HsDoc stuff
-%*							 *
+%*                                                       *
+        HsDoc stuff
+%*                                                       *
 %*********************************************************
 
 \begin{code}
 rnDocDecl :: DocDecl -> RnM DocDecl
-rnDocDecl (DocCommentNext doc) = do 
+rnDocDecl (DocCommentNext doc) = do
   rn_doc <- rnHsDoc doc
   return (DocCommentNext rn_doc)
-rnDocDecl (DocCommentPrev doc) = do 
+rnDocDecl (DocCommentPrev doc) = do
   rn_doc <- rnHsDoc doc
   return (DocCommentPrev rn_doc)
 rnDocDecl (DocCommentNamed str doc) = do
@@ -243,9 +236,9 @@ rnDocDecl (DocGroup lev doc) = do
 
 
 %*********************************************************
-%*						 	 *
-	Source-code fixity declarations
-%*							 *
+%*                                                       *
+        Source-code fixity declarations
+%*                                                       *
 %*********************************************************
 
 \begin{code}
@@ -260,14 +253,14 @@ rnSrcFixityDecls bndr_set fix_decls
   = do fix_decls <- mapM rn_decl fix_decls
        return (concat fix_decls)
   where
-    sig_ctxt = TopSigCtxt bndr_set True  
+    sig_ctxt = TopSigCtxt bndr_set True
        -- True <=> can give fixity for class decls and record selectors
 
     rn_decl :: LFixitySig RdrName -> RnM [LFixitySig Name]
-        -- GHC extension: look up both the tycon and data con 
-	-- for con-like things; hence returning a list
-	-- If neither are in scope, report an error; otherwise
-	-- return a fixity sig for each (slightly odd)
+        -- GHC extension: look up both the tycon and data con
+        -- for con-like things; hence returning a list
+        -- If neither are in scope, report an error; otherwise
+        -- return a fixity sig for each (slightly odd)
     rn_decl (L loc (FixitySig (L name_loc rdr_name) fixity))
       = setSrcSpan name_loc $
                     -- this lookup will fail if the definition isn't local
@@ -279,9 +272,9 @@ rnSrcFixityDecls bndr_set fix_decls
 
 
 %*********************************************************
-%*						 	 *
-	Source-code deprecations declarations
-%*							 *
+%*                                                       *
+        Source-code deprecations declarations
+%*                                                       *
 %*********************************************************
 
 Check that the deprecated names are defined, are defined locally, and
@@ -293,13 +286,13 @@ gather them together.
 \begin{code}
 -- checks that the deprecations are defined locally, and that there are no duplicates
 rnSrcWarnDecls :: NameSet -> [LWarnDecl RdrName] -> RnM Warnings
-rnSrcWarnDecls _ [] 
+rnSrcWarnDecls _ []
   = return NoWarnings
 
-rnSrcWarnDecls bndr_set decls 
+rnSrcWarnDecls bndr_set decls
   = do { -- check for duplicates
        ; mapM_ (\ dups -> let (L loc rdr:lrdr':_) = dups
-                          in addErrAt loc (dupWarnDecl lrdr' rdr)) 
+                          in addErrAt loc (dupWarnDecl lrdr' rdr))
                warn_rdr_dups
        ; pairs_s <- mapM (addLocM rn_deprec) decls
        ; return (WarnSome ((concat pairs_s))) }
@@ -311,7 +304,7 @@ rnSrcWarnDecls bndr_set decls
        -- ensures that the names are defined locally
      = do { names <- lookupLocalTcNames sig_ctxt what rdr_name
           ; return [(nameOccName name, txt) | name <- names] }
-   
+
    what = ptext (sLit "deprecation")
 
    warn_rdr_dups = findDupRdrNames (map (\ (L loc (Warning rdr_name _)) -> L loc rdr_name) decls)
@@ -322,7 +315,7 @@ findDupRdrNames = findDupsEq (\ x -> \ y -> rdrNameOcc (unLoc x) == rdrNameOcc (
 -- look for duplicates among the OccNames;
 -- we check that the names are defined above
 -- invt: the lists returned by findDupsEq always have at least two elements
-               
+
 dupWarnDecl :: Located RdrName -> RdrName -> SDoc
 -- Located RdrName -> DeprecDecl RdrName -> SDoc
 dupWarnDecl (L loc _) rdr_name
@@ -332,9 +325,9 @@ dupWarnDecl (L loc _) rdr_name
 \end{code}
 
 %*********************************************************
-%*							*
+%*                                                      *
 \subsection{Annotation declarations}
-%*							*
+%*                                                      *
 %*********************************************************
 
 \begin{code}
@@ -351,9 +344,9 @@ rnAnnProvenance provenance = do
 \end{code}
 
 %*********************************************************
-%*							*
+%*                                                      *
 \subsection{Default declarations}
-%*							*
+%*                                                      *
 %*********************************************************
 
 \begin{code}
@@ -366,9 +359,9 @@ rnDefaultDecl (DefaultDecl tys)
 \end{code}
 
 %*********************************************************
-%*							*
+%*                                                      *
 \subsection{Foreign declarations}
-%*							*
+%*                                                      *
 %*********************************************************
 
 \begin{code}
@@ -380,7 +373,7 @@ rnHsForeignDecl (ForeignImport name ty _ spec)
 
         -- Mark any PackageTarget style imports as coming from the current package
        ; let packageId = thisPackage $ hsc_dflags topEnv
-	     spec'     = patchForeignImport packageId spec
+             spec'     = patchForeignImport packageId spec
 
        ; return (ForeignImport name' ty' noForeignImportCoercionYet spec', fvs) }
 
@@ -388,52 +381,50 @@ rnHsForeignDecl (ForeignExport name ty _ spec)
   = do { name' <- lookupLocatedOccRn name
        ; (ty', fvs) <- rnLHsType (ForeignDeclCtx name) ty
        ; return (ForeignExport name' ty' noForeignExportCoercionYet spec, fvs `addOneFV` unLoc name') }
-	-- NB: a foreign export is an *occurrence site* for name, so 
-	--     we add it to the free-variable list.  It might, for example,
-	--     be imported from another module
+        -- NB: a foreign export is an *occurrence site* for name, so
+        --     we add it to the free-variable list.  It might, for example,
+        --     be imported from another module
 
 -- | For Windows DLLs we need to know what packages imported symbols are from
---	to generate correct calls. Imported symbols are tagged with the current
---	package, so if they get inlined across a package boundry we'll still
---	know where they're from.
+--      to generate correct calls. Imported symbols are tagged with the current
+--      package, so if they get inlined across a package boundry we'll still
+--      know where they're from.
 --
 patchForeignImport :: PackageId -> ForeignImport -> ForeignImport
 patchForeignImport packageId (CImport cconv safety fs spec)
-	= CImport cconv safety fs (patchCImportSpec packageId spec) 
+        = CImport cconv safety fs (patchCImportSpec packageId spec)
 
 patchCImportSpec :: PackageId -> CImportSpec -> CImportSpec
 patchCImportSpec packageId spec
  = case spec of
-	CFunction callTarget	-> CFunction $ patchCCallTarget packageId callTarget
-	_			-> spec
+        CFunction callTarget    -> CFunction $ patchCCallTarget packageId callTarget
+        _                       -> spec
 
 patchCCallTarget :: PackageId -> CCallTarget -> CCallTarget
-patchCCallTarget packageId callTarget
- = case callTarget of
- 	StaticTarget label Nothing isFun
-	 -> StaticTarget label (Just packageId) isFun
-
-	_			-> callTarget	
+patchCCallTarget packageId callTarget =
+  case callTarget of
+  StaticTarget label Nothing isFun -> StaticTarget label (Just packageId) isFun
+  _                                -> callTarget
 
 
 \end{code}
 
 
 %*********************************************************
-%*							*
+%*                                                      *
 \subsection{Instance declarations}
-%*							*
+%*                                                      *
 %*********************************************************
 
 \begin{code}
 rnSrcInstDecl :: InstDecl RdrName -> RnM (InstDecl Name, FreeVars)
-rnSrcInstDecl (FamInstD { lid_inst = fi }) 
+rnSrcInstDecl (FamInstD { lid_inst = fi })
   = do { (fi', fvs) <- rnFamInstDecl Nothing fi
        ; return (FamInstD { lid_inst = fi' }, fvs) }
 
 rnSrcInstDecl (ClsInstD { cid_poly_ty = inst_ty, cid_binds = mbinds
                         , cid_sigs = uprags, cid_fam_insts = ats })
-	-- Used for both source and interface file decls
+        -- Used for both source and interface file decls
   = do { (inst_ty', inst_fvs) <- rnLHsInstType (text "In an instance declaration") inst_ty
        ; case splitLHsInstDeclTy_maybe inst_ty' of {
            Nothing -> return (ClsInstD { cid_poly_ty = inst_ty', cid_binds = emptyLHsBinds
@@ -447,48 +438,48 @@ rnSrcInstDecl (ClsInstD { cid_poly_ty = inst_ty, cid_binds = mbinds
        -- Rename the associated types, and type signatures
        -- Both need to have the instance type variables in scope
        ; traceRn (text "rnSrcInstDecl"  <+> ppr inst_ty' $$ ppr inst_tyvars $$ ppr ktv_names)
-       ; ((ats', other_sigs'), more_fvs) 
+       ; ((ats', other_sigs'), more_fvs)
              <- extendTyVarEnvFVRn ktv_names $
                 do { (ats', at_fvs) <- rnATInstDecls cls inst_tyvars ats
                    ; (other_sigs', sig_fvs) <- renameSigs (InstDeclCtxt cls) other_sigs
                    ; return ( (ats', other_sigs')
                             , at_fvs `plusFV` sig_fvs) }
 
-	-- Rename the bindings
-	-- The typechecker (not the renamer) checks that all 
-	-- the bindings are for the right class
-	-- (Slightly strangely) when scoped type variables are on, the 
+        -- Rename the bindings
+        -- The typechecker (not the renamer) checks that all
+        -- the bindings are for the right class
+        -- (Slightly strangely) when scoped type variables are on, the
         -- forall-d tyvars scope over the method bindings too
        ; (mbinds', meth_fvs) <- extendTyVarEnvForMethodBinds ktv_names $
                                 rnMethodBinds cls (mkSigTvFn other_sigs')
-					          mbinds    
-
-	-- Rename the SPECIALISE instance pramas
-	-- Annoyingly the type variables are not in scope here,
-	-- so that	instance Eq a => Eq (T a) where
-	--			{-# SPECIALISE instance Eq a => Eq (T [a]) #-}
-	-- works OK. That's why we did the partition game above
-	--
+                                                  mbinds
+
+        -- Rename the SPECIALISE instance pramas
+        -- Annoyingly the type variables are not in scope here,
+        -- so that      instance Eq a => Eq (T a) where
+        --                      {-# SPECIALISE instance Eq a => Eq (T [a]) #-}
+        -- works OK. That's why we did the partition game above
+        --
        ; (spec_inst_prags', spec_inst_fvs)
-	     <- renameSigs (InstDeclCtxt cls) spec_inst_prags
+             <- renameSigs (InstDeclCtxt cls) spec_inst_prags
 
        ; let uprags' = spec_inst_prags' ++ other_sigs'
              all_fvs = meth_fvs `plusFV` more_fvs
                           `plusFV` spec_inst_fvs
-		      	  `plusFV` inst_fvs
+                          `plusFV` inst_fvs
        ; return (ClsInstD { cid_poly_ty = inst_ty', cid_binds = mbinds'
                           , cid_sigs = uprags', cid_fam_insts = ats' },
-	         all_fvs) } } }
+                 all_fvs) } } }
              -- We return the renamed associated data type declarations so
              -- that they can be entered into the list of type declarations
              -- for the binding group, but we also keep a copy in the instance.
              -- The latter is needed for well-formedness checks in the type
              -- checker (eg, to ensure that all ATs of the instance actually
-             -- receive a declaration). 
-	     -- NB: Even the copies in the instance declaration carry copies of
-	     --     the instance context after renaming.  This is a bit
-	     --     strange, but should not matter (and it would be more work
-	     --     to remove the context).
+             -- receive a declaration).
+             -- NB: Even the copies in the instance declaration carry copies of
+             --     the instance context after renaming.  This is a bit
+             --     strange, but should not matter (and it would be more work
+             --     to remove the context).
 
 rnFamInstDecl :: Maybe (Name, [Name]) -> FamInstDecl RdrName -> RnM (FamInstDecl Name, FreeVars)
 rnFamInstDecl mb_cls (FamInstDecl { fid_tycon = tycon
@@ -505,15 +496,15 @@ rnFamInstDecl mb_cls (FamInstDecl { fid_tycon = tycon
        ; rdr_env  <- getLocalRdrEnv
        ; kv_names <- mapM (newTyVarNameRn mb_cls rdr_env loc) kv_rdr_names
        ; tv_names <- mapM (newTyVarNameRn mb_cls rdr_env loc) tv_rdr_names
-       	     -- All the free vars of the family patterns
+             -- All the free vars of the family patterns
              -- with a sensible binding location
-       ; ((pats', defn'), fvs) 
-              <- bindLocalNamesFV kv_names $ 
-                 bindLocalNamesFV tv_names $ 
-    	 	 do { (pats', pat_fvs) <- rnLHsTypes (TyDataCtx tycon) pats
-    		    ; (defn', rhs_fvs) <- rnTyDefn tycon defn
+       ; ((pats', defn'), fvs)
+              <- bindLocalNamesFV kv_names $
+                 bindLocalNamesFV tv_names $
+                 do { (pats', pat_fvs) <- rnLHsTypes (TyDataCtx tycon) pats
+                    ; (defn', rhs_fvs) <- rnTyDefn tycon defn
 
-                         -- See Note [Renaming associated types] 
+                         -- See Note [Renaming associated types]
                     ; let bad_tvs = case mb_cls of
                                       Nothing          -> []
                                       Just (_,cls_tvs) -> filter is_bad cls_tvs
@@ -521,22 +512,22 @@ rnFamInstDecl mb_cls (FamInstDecl { fid_tycon = tycon
 
                     ; unless (null bad_tvs) (badAssocRhs bad_tvs)
                     ; return ((pats', defn'), rhs_fvs `plusFV` pat_fvs) }
-                              
+
 
        ; let all_fvs = fvs `addOneFV` unLoc tycon'
        ; return ( FamInstDecl { fid_tycon = tycon'
                               , fid_pats  = HsWB { hswb_cts = pats', hswb_kvs = kv_names, hswb_tvs = tv_names }
                               , fid_defn  = defn', fid_fvs = all_fvs }
                 , all_fvs ) }
-       	     -- type instance => use, hence addOneFV
+             -- type instance => use, hence addOneFV
 \end{code}
 
-Renaming of the associated types in instances.  
+Renaming of the associated types in instances.
 
 \begin{code}
 rnATDecls :: Name      -- Class
           -> LHsTyVarBndrs Name
-          -> [LTyClDecl RdrName] 
+          -> [LTyClDecl RdrName]
           -> RnM ([LTyClDecl Name], FreeVars)
 rnATDecls cls hs_tvs at_decls
   = rnList (rnTyClDecl (Just (cls, tv_ns))) at_decls
@@ -547,12 +538,12 @@ rnATDecls cls hs_tvs at_decls
 
 rnATInstDecls :: Name      -- Class
               -> LHsTyVarBndrs Name
-              -> [LFamInstDecl RdrName] 
+              -> [LFamInstDecl RdrName]
               -> RnM ([LFamInstDecl Name], FreeVars)
 -- Used for the family declarations and defaults in a class decl
 -- and the family instance declarations in an instance
--- 
--- NB: We allow duplicate associated-type decls; 
+--
+-- NB: We allow duplicate associated-type decls;
 --     See Note [Associated type instances] in TcInstDcls
 rnATInstDecls cls hs_tvs at_insts
   = rnList (rnFamInstDecl (Just (cls, tv_ns))) at_insts
@@ -562,7 +553,7 @@ rnATInstDecls cls hs_tvs at_insts
     -- See Note [Renaming associated types] in RnTypes
 \end{code}
 
-For the method bindings in class and instance decls, we extend the 
+For the method bindings in class and instance decls, we extend the
 type variable environment iff -fglasgow-exts
 
 \begin{code}
@@ -570,17 +561,17 @@ extendTyVarEnvForMethodBinds :: [Name]
                              -> RnM (Bag (LHsBind Name), FreeVars)
                              -> RnM (Bag (LHsBind Name), FreeVars)
 extendTyVarEnvForMethodBinds ktv_names thing_inside
-  = do	{ scoped_tvs <- xoptM Opt_ScopedTypeVariables
-	; if scoped_tvs then
-		extendTyVarEnvFVRn ktv_names thing_inside
-	  else
-		thing_inside }
+  = do  { scoped_tvs <- xoptM Opt_ScopedTypeVariables
+        ; if scoped_tvs then
+                extendTyVarEnvFVRn ktv_names thing_inside
+          else
+                thing_inside }
 \end{code}
 
 %*********************************************************
-%*							*
+%*                                                      *
 \subsection{Stand-alone deriving declarations}
-%*							*
+%*                                                      *
 %*********************************************************
 
 \begin{code}
@@ -592,15 +583,15 @@ rnSrcDerivDecl (DerivDecl ty)
        ; return (DerivDecl ty', fvs) }
 
 standaloneDerivErr :: SDoc
-standaloneDerivErr 
+standaloneDerivErr
   = hang (ptext (sLit "Illegal standalone deriving declaration"))
        2 (ptext (sLit "Use -XStandaloneDeriving to enable this extension"))
 \end{code}
 
 %*********************************************************
-%*							*
+%*                                                      *
 \subsection{Rules}
-%*							*
+%*                                                      *
 %*********************************************************
 
 \begin{code}
@@ -610,12 +601,12 @@ rnHsRuleDecl (HsRule rule_name act vars lhs _fv_lhs rhs _fv_rhs)
        ; checkDupRdrNames rdr_names_w_loc
        ; checkShadowedRdrNames rdr_names_w_loc
        ; names <- newLocalBndrsRn rdr_names_w_loc
-       ; bindHsRuleVars rule_name vars names $ \ vars' -> 
+       ; bindHsRuleVars rule_name vars names $ \ vars' ->
     do { (lhs', fv_lhs') <- rnLExpr lhs
        ; (rhs', fv_rhs') <- rnLExpr rhs
        ; checkValidRule rule_name names lhs' fv_lhs'
        ; return (HsRule rule_name act vars' lhs' fv_lhs' rhs' fv_rhs',
-		 fv_lhs' `plusFV` fv_rhs') } }
+                 fv_lhs' `plusFV` fv_rhs') } }
   where
     get_var (RuleBndrSig v _) = v
     get_var (RuleBndr v) = v
@@ -646,7 +637,7 @@ Note [Rule LHS validity checking]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Check the shape of a transformation rule LHS.  Currently we only allow
 LHSs of the form @(f e1 .. en)@, where @f@ is not one of the
-@forall@'d variables.  
+@forall@'d variables.
 
 We used restrict the form of the 'ei' to prevent you writing rules
 with LHSs with a complicated desugaring (and hence unlikely to match);
@@ -655,18 +646,18 @@ with LHSs with a complicated desugaring (and hence unlikely to match);
 But there are legitimate non-trivial args ei, like sections and
 lambdas.  So it seems simmpler not to check at all, and that is why
 check_e is commented out.
-	
+
 \begin{code}
 checkValidRule :: FastString -> [Name] -> LHsExpr Name -> NameSet -> RnM ()
 checkValidRule rule_name ids lhs' fv_lhs'
-  = do 	{ 	-- Check for the form of the LHS
-	  case (validRuleLhs ids lhs') of
-		Nothing  -> return ()
-		Just bad -> failWithTc (badRuleLhsErr rule_name lhs' bad)
+  = do  {       -- Check for the form of the LHS
+          case (validRuleLhs ids lhs') of
+                Nothing  -> return ()
+                Just bad -> failWithTc (badRuleLhsErr rule_name lhs' bad)
 
-		-- Check that LHS vars are all bound
-	; let bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs')]
-	; mapM_ (addErr . badRuleVar rule_name) bad_vars }
+                -- Check that LHS vars are all bound
+        ; let bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs')]
+        ; mapM_ (addErr . badRuleVar rule_name) bad_vars }
 
 validRuleLhs :: [Name] -> LHsExpr Name -> Maybe (HsExpr Name)
 -- Nothing => OK
@@ -676,25 +667,25 @@ validRuleLhs foralls lhs
   where
     checkl (L _ e) = check e
 
-    check (OpApp e1 op _ e2)		  = checkl op `mplus` checkl_e e1 `mplus` checkl_e e2
-    check (HsApp e1 e2) 		  = checkl e1 `mplus` checkl_e e2
+    check (OpApp e1 op _ e2)              = checkl op `mplus` checkl_e e1 `mplus` checkl_e e2
+    check (HsApp e1 e2)                   = checkl e1 `mplus` checkl_e e2
     check (HsVar v) | v `notElem` foralls = Nothing
-    check other				  = Just other 	-- Failure
+    check other                           = Just other  -- Failure
 
-	-- Check an argument
-    checkl_e (L _ _e) = Nothing 	-- Was (check_e e); see Note [Rule LHS validity checking]
+        -- Check an argument
+    checkl_e (L _ _e) = Nothing         -- Was (check_e e); see Note [Rule LHS validity checking]
 
-{-	Commented out; see Note [Rule LHS validity checking] above 
+{-      Commented out; see Note [Rule LHS validity checking] above
     check_e (HsVar v)     = Nothing
-    check_e (HsPar e) 	  = checkl_e e
-    check_e (HsLit e) 	  = Nothing
+    check_e (HsPar e)     = checkl_e e
+    check_e (HsLit e)     = Nothing
     check_e (HsOverLit e) = Nothing
 
-    check_e (OpApp e1 op _ e2) 	 = checkl_e e1 `mplus` checkl_e op `mplus` checkl_e e2
-    check_e (HsApp e1 e2)      	 = checkl_e e1 `mplus` checkl_e e2
-    check_e (NegApp e _)       	 = checkl_e e
-    check_e (ExplicitList _ es)	 = checkl_es es
-    check_e other		 = Just other	-- Fails
+    check_e (OpApp e1 op _ e2)   = checkl_e e1 `mplus` checkl_e op `mplus` checkl_e e2
+    check_e (HsApp e1 e2)        = checkl_e e1 `mplus` checkl_e e2
+    check_e (NegApp e _)         = checkl_e e
+    check_e (ExplicitList _ es)  = checkl_es es
+    check_e other                = Just other   -- Fails
 
     checkl_es es = foldr (mplus . checkl_e) Nothing es
 -}
@@ -702,14 +693,14 @@ validRuleLhs foralls lhs
 badRuleVar :: FastString -> Name -> SDoc
 badRuleVar name var
   = sep [ptext (sLit "Rule") <+> doubleQuotes (ftext name) <> colon,
-	 ptext (sLit "Forall'd variable") <+> quotes (ppr var) <+> 
-		ptext (sLit "does not appear on left hand side")]
+         ptext (sLit "Forall'd variable") <+> quotes (ppr var) <+>
+                ptext (sLit "does not appear on left hand side")]
 
 badRuleLhsErr :: FastString -> LHsExpr Name -> HsExpr Name -> SDoc
 badRuleLhsErr name lhs bad_e
   = sep [ptext (sLit "Rule") <+> ftext name <> colon,
-	 nest 4 (vcat [ptext (sLit "Illegal expression:") <+> ppr bad_e, 
-		       ptext (sLit "in left-hand side:") <+> ppr lhs])]
+         nest 4 (vcat [ptext (sLit "Illegal expression:") <+> ppr bad_e,
+                       ptext (sLit "in left-hand side:") <+> ppr lhs])]
     $$
     ptext (sLit "LHS must be of form (f e1 .. en) where f is not forall'd")
 \end{code}
@@ -735,7 +726,7 @@ rnHsVectDecl (HsVect var (Just rhs@(L _ (HsVar _))))
        ; return (HsVect var' (Just rhs'), fv_rhs `addOneFV` unLoc var')
        }
 rnHsVectDecl (HsVect _var (Just _rhs))
-  = failWith $ vcat 
+  = failWith $ vcat
                [ ptext (sLit "IMPLEMENTATION RESTRICTION: right-hand side of a VECTORISE pragma")
                , ptext (sLit "must be an identifier")
                ]
@@ -796,7 +787,7 @@ Consider the following case:
   module A where
     import B
     data A1 = A1 B1
-  
+
   module B where
     import {-# SOURCE #-} A
     type DisguisedA1 = A1
@@ -849,19 +840,19 @@ rnTyClDecls extra_deps tycl_ds
        ; return (map flattenSCC sccs, all_fvs) }
 
 
-rnTyClDecl :: Maybe (Name, [Name])  
-                    -- Just (cls,tvs) => this TyClDecl is nested 
+rnTyClDecl :: Maybe (Name, [Name])
+                    -- Just (cls,tvs) => this TyClDecl is nested
                     --             inside an *instance decl* for cls
                     --             used for associated types
-           -> TyClDecl RdrName 
+           -> TyClDecl RdrName
            -> RnM (TyClDecl Name, FreeVars)
 rnTyClDecl _ (ForeignType {tcdLName = name, tcdExtName = ext_name})
   = do { name' <- lookupLocatedTopBndrRn name
        ; return (ForeignType {tcdLName = name', tcdExtName = ext_name},
-	         emptyFVs) }
+                 emptyFVs) }
 
 -- All flavours of type family declarations ("type family", "newtype family",
--- and "data family"), both top level and (for an associated type) 
+-- and "data family"), both top level and (for an associated type)
 -- in a class decl
 rnTyClDecl mb_cls (TyFamily { tcdLName = tycon, tcdTyVars = tyvars
                             , tcdFlavour = flav, tcdKindSig = kind })
@@ -871,7 +862,7 @@ rnTyClDecl mb_cls (TyFamily { tcdLName = tycon, tcdTyVars = tyvars
        ; return ( TyFamily { tcdLName = tycon', tcdTyVars = tyvars'
                            , tcdFlavour = flav, tcdKindSig = kind' }
                 , fv_kind ) }
-  where 
+  where
      fmly_doc = TyFamilyCtx tycon
      kvs = extractRdrKindSigVars kind
 
@@ -887,110 +878,110 @@ rnTyClDecl mb_cls (TyDecl { tcdLName = tycon, tcdTyVars = tyvars, tcdTyDefn = de
        ; return (TyDecl { tcdLName = tycon', tcdTyVars = tyvars'
                         , tcdTyDefn = defn', tcdFVs = fvs }, fvs) }
 
-rnTyClDecl mb_cls (ClassDecl {tcdCtxt = context, tcdLName = lcls, 
-		              tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs, 
-		              tcdMeths = mbinds, tcdATs = ats, tcdATDefs = at_defs,
+rnTyClDecl mb_cls (ClassDecl {tcdCtxt = context, tcdLName = lcls,
+                              tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs,
+                              tcdMeths = mbinds, tcdATs = ats, tcdATDefs = at_defs,
                               tcdDocs = docs})
-  = do	{ lcls' <- lookupLocatedTopBndrRn lcls
+  = do  { lcls' <- lookupLocatedTopBndrRn lcls
         ; let cls' = unLoc lcls'
-              kvs = []  -- No scoped kind vars except those in 
+              kvs = []  -- No scoped kind vars except those in
                         -- kind signatures on the tyvars
 
-	-- Tyvars scope over superclass context and method signatures
-	; ((tyvars', context', fds', ats', at_defs', sigs'), stuff_fvs)
-	    <- bindHsTyVars cls_doc mb_cls kvs tyvars $ \ tyvars' -> do
-         	 -- Checks for distinct tyvars
-	     { (context', cxt_fvs) <- rnContext cls_doc context
-	     ; fds'  <- rnFds (docOfHsDocContext cls_doc) fds
-			 -- The fundeps have no free variables
+        -- Tyvars scope over superclass context and method signatures
+        ; ((tyvars', context', fds', ats', at_defs', sigs'), stuff_fvs)
+            <- bindHsTyVars cls_doc mb_cls kvs tyvars $ \ tyvars' -> do
+                 -- Checks for distinct tyvars
+             { (context', cxt_fvs) <- rnContext cls_doc context
+             ; fds'  <- rnFds (docOfHsDocContext cls_doc) fds
+                         -- The fundeps have no free variables
              ; (ats',     fv_ats)     <- rnATDecls cls' tyvars' ats
              ; (at_defs', fv_at_defs) <- rnATInstDecls cls' tyvars' at_defs
-	     ; (sigs', sig_fvs) <- renameSigs (ClsDeclCtxt cls') sigs
-	     ; let fvs = cxt_fvs     `plusFV`
-	                 sig_fvs     `plusFV`
+             ; (sigs', sig_fvs) <- renameSigs (ClsDeclCtxt cls') sigs
+             ; let fvs = cxt_fvs     `plusFV`
+                         sig_fvs     `plusFV`
                          fv_ats      `plusFV`
                          fv_at_defs
-	     ; return ((tyvars', context', fds', ats', at_defs', sigs'), fvs) }
-
-	-- No need to check for duplicate associated type decls
-	-- since that is done by RnNames.extendGlobalRdrEnvRn
-
-	-- Check the signatures
-	-- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs).
-	; let sig_rdr_names_w_locs = [op | L _ (TypeSig ops _) <- sigs, op <- ops]
-	; checkDupRdrNames sig_rdr_names_w_locs
-		-- Typechecker is responsible for checking that we only
-		-- give default-method bindings for things in this class.
-		-- The renamer *could* check this for class decls, but can't
-		-- for instance decls.
-
-   	-- The newLocals call is tiresome: given a generic class decl
-	--	class C a where
-	--	  op :: a -> a
-	--	  op {| x+y |} (Inl a) = ...
-	--	  op {| x+y |} (Inr b) = ...
-	--	  op {| a*b |} (a*b)   = ...
-	-- we want to name both "x" tyvars with the same unique, so that they are
-	-- easy to group together in the typechecker.  
-	; (mbinds', meth_fvs) 
-	    <- extendTyVarEnvForMethodBinds (hsLKiTyVarNames tyvars') $
-		-- No need to check for duplicate method signatures
-		-- since that is done by RnNames.extendGlobalRdrEnvRn
-		-- and the methods are already in scope
-	         rnMethodBinds cls' (mkSigTvFn sigs') mbinds
-
-  -- Haddock docs 
-	; docs' <- mapM (wrapLocM rnDocDecl) docs
+             ; return ((tyvars', context', fds', ats', at_defs', sigs'), fvs) }
+
+        -- No need to check for duplicate associated type decls
+        -- since that is done by RnNames.extendGlobalRdrEnvRn
+
+        -- Check the signatures
+        -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs).
+        ; let sig_rdr_names_w_locs = [op | L _ (TypeSig ops _) <- sigs, op <- ops]
+        ; checkDupRdrNames sig_rdr_names_w_locs
+                -- Typechecker is responsible for checking that we only
+                -- give default-method bindings for things in this class.
+                -- The renamer *could* check this for class decls, but can't
+                -- for instance decls.
+
+        -- The newLocals call is tiresome: given a generic class decl
+        --      class C a where
+        --        op :: a -> a
+        --        op {| x+y |} (Inl a) = ...
+        --        op {| x+y |} (Inr b) = ...
+        --        op {| a*b |} (a*b)   = ...
+        -- we want to name both "x" tyvars with the same unique, so that they are
+        -- easy to group together in the typechecker.
+        ; (mbinds', meth_fvs)
+            <- extendTyVarEnvForMethodBinds (hsLKiTyVarNames tyvars') $
+                -- No need to check for duplicate method signatures
+                -- since that is done by RnNames.extendGlobalRdrEnvRn
+                -- and the methods are already in scope
+                 rnMethodBinds cls' (mkSigTvFn sigs') mbinds
+
+  -- Haddock docs
+        ; docs' <- mapM (wrapLocM rnDocDecl) docs
 
         ; let all_fvs = meth_fvs `plusFV` stuff_fvs
-	; return (ClassDecl { tcdCtxt = context', tcdLName = lcls', 
-			      tcdTyVars = tyvars', tcdFDs = fds', tcdSigs = sigs',
-			      tcdMeths = mbinds', tcdATs = ats', tcdATDefs = at_defs',
+        ; return (ClassDecl { tcdCtxt = context', tcdLName = lcls',
+                              tcdTyVars = tyvars', tcdFDs = fds', tcdSigs = sigs',
+                              tcdMeths = mbinds', tcdATs = ats', tcdATDefs = at_defs',
                               tcdDocs = docs', tcdFVs = all_fvs },
-	     	  all_fvs ) }
+                  all_fvs ) }
   where
     cls_doc  = ClassDeclCtx lcls
 
 
 rnTyDefn :: Located RdrName -> HsTyDefn RdrName -> RnM (HsTyDefn Name, FreeVars)
 rnTyDefn tycon (TyData { td_ND = new_or_data, td_cType = cType
-               , td_ctxt = context, td_cons = condecls 
-	       , td_kindSig = sig, td_derivs = derivs })
-  = do	{ checkTc (h98_style || null (unLoc context)) 
+               , td_ctxt = context, td_cons = condecls
+               , td_kindSig = sig, td_derivs = derivs })
+  = do  { checkTc (h98_style || null (unLoc context))
                   (badGadtStupidTheta tycon)
 
         ; (sig', sig_fvs)  <- rnLHsMaybeKind data_doc sig
         ; (context', fvs1) <- rnContext data_doc context
         ; (derivs',  fvs3) <- rn_derivs derivs
 
-	-- For the constructor declarations, drop the LocalRdrEnv
-        -- in the GADT case, where the type variables in the declaration 
-	-- do not scope over the constructor signatures
-	-- data T a where { T1 :: forall b. b-> b }
+        -- For the constructor declarations, drop the LocalRdrEnv
+        -- in the GADT case, where the type variables in the declaration
+        -- do not scope over the constructor signatures
+        -- data T a where { T1 :: forall b. b-> b }
         ; let { zap_lcl_env | h98_style = \ thing -> thing
                             | otherwise = setLocalRdrEnv emptyLocalRdrEnv }
-	; (condecls', con_fvs) <- zap_lcl_env $
+        ; (condecls', con_fvs) <- zap_lcl_env $
                                   rnConDecls condecls
            -- No need to check for duplicate constructor decls
-	   -- since that is done by RnNames.extendGlobalRdrEnvRn
+           -- since that is done by RnNames.extendGlobalRdrEnvRn
 
         ; let all_fvs = fvs1 `plusFV` fvs3 `plusFV`
                         con_fvs `plusFV` sig_fvs
-	; return ( TyData { td_ND = new_or_data, td_cType = cType
+        ; return ( TyData { td_ND = new_or_data, td_cType = cType
                           , td_ctxt = context', td_kindSig = sig'
-			  , td_cons = condecls', td_derivs = derivs' }
+                          , td_cons = condecls', td_derivs = derivs' }
                  , all_fvs )
         }
   where
-    h98_style = case condecls of	 -- Note [Stupid theta]
-		     L _ (ConDecl { con_res = ResTyGADT {} }) : _  -> False
-		     _    		                           -> True
+    h98_style = case condecls of         -- Note [Stupid theta]
+                     L _ (ConDecl { con_res = ResTyGADT {} }) : _  -> False
+                     _                                             -> True
 
     data_doc = TyDataCtx tycon
 
     rn_derivs Nothing   = return (Nothing, emptyFVs)
     rn_derivs (Just ds) = do { (ds', fvs) <- rnLHsTypes data_doc ds
-			     ; return (Just ds', fvs) }
+                             ; return (Just ds', fvs) }
 
 -- "type" and "type instance" declarations
 rnTyDefn tycon (TySynonym { td_synRhs = ty })
@@ -1003,12 +994,12 @@ rnTyDefn tycon (TySynonym { td_synRhs = ty })
 badGadtStupidTheta :: Located RdrName -> SDoc
 badGadtStupidTheta _
   = vcat [ptext (sLit "No context is allowed on a GADT-style data declaration"),
-	  ptext (sLit "(You can put a context on each contructor, though.)")]
+          ptext (sLit "(You can put a context on each contructor, though.)")]
 \end{code}
 
 Note [Stupid theta]
 ~~~~~~~~~~~~~~~~~~~
-Trac #3850 complains about a regression wrt 6.10 for 
+Trac #3850 complains about a regression wrt 6.10 for
      data Show a => T a
 There is no reason not to allow the stupid theta if there are no data
 constructors.  It's still stupid, but does no harm, and I don't want
@@ -1025,22 +1016,22 @@ depAnalTyClDecls ds_w_fvs
     edges = [ (d, tcdName (unLoc d), map get_parent (nameSetToList fvs))
             | (d, fvs) <- ds_w_fvs ]
 
-    -- We also need to consider data constructor names since 
+    -- We also need to consider data constructor names since
     -- they may appear in types because of promotion.
     get_parent n = lookupNameEnv assoc_env n `orElse` n
 
-    assoc_env :: NameEnv Name   -- Maps a data constructor back 
+    assoc_env :: NameEnv Name   -- Maps a data constructor back
                                 -- to its parent type constructor
     assoc_env = mkNameEnv assoc_env_list
     assoc_env_list = do
       (L _ d, _) <- ds_w_fvs
       case d of
         ClassDecl { tcdLName = L _ cls_name
-                  , tcdATs = ats } 
+                  , tcdATs = ats }
           -> do L _ assoc_decl <- ats
                 return (tcdName assoc_decl, cls_name)
         TyDecl { tcdLName = L _ data_name
-               , tcdTyDefn = TyData { td_cons = cons } } 
+               , tcdTyDefn = TyData { td_cons = cons } }
           -> do L _ dc <- cons
                 return (unLoc (con_name dc), data_name)
         _ -> []
@@ -1061,17 +1052,17 @@ is jolly confusing.  See Trac #4875
 
 
 %*********************************************************
-%*							*
+%*                                                      *
 \subsection{Support code for type/data declarations}
-%*							*
+%*                                                      *
 %*********************************************************
 
 \begin{code}
 ---------------
 badAssocRhs :: [Name] -> RnM ()
 badAssocRhs ns
-  = addErr (hang (ptext (sLit "The RHS of an associated type declaration mentions type variable") 
-                  <> plural ns 
+  = addErr (hang (ptext (sLit "The RHS of an associated type declaration mentions type variable")
+                  <> plural ns
                   <+> pprWithCommas (quotes . ppr) ns)
                2 (ptext (sLit "All such variables must be bound on the LHS")))
 
@@ -1081,36 +1072,36 @@ rnConDecls = mapFvRn (wrapLocFstM rnConDecl)
 
 rnConDecl :: ConDecl RdrName -> RnM (ConDecl Name, FreeVars)
 rnConDecl decl@(ConDecl { con_name = name, con_qvars = tvs
-                   	, con_cxt = lcxt@(L loc cxt), con_details = details
-                   	, con_res = res_ty, con_doc = mb_doc
-                   	, con_old_rec = old_rec, con_explicit = expl })
-  = do	{ addLocM checkConName name
-    	; when old_rec (addWarn (deprecRecSyntax decl))
-	; new_name <- lookupLocatedTopBndrRn name
-
-    	   -- For H98 syntax, the tvs are the existential ones
-	   -- For GADT syntax, the tvs are all the quantified tyvars
-	   -- Hence the 'filter' in the ResTyH98 case only
+                        , con_cxt = lcxt@(L loc cxt), con_details = details
+                        , con_res = res_ty, con_doc = mb_doc
+                        , con_old_rec = old_rec, con_explicit = expl })
+  = do  { addLocM checkConName name
+        ; when old_rec (addWarn (deprecRecSyntax decl))
+        ; new_name <- lookupLocatedTopBndrRn name
+
+           -- For H98 syntax, the tvs are the existential ones
+           -- For GADT syntax, the tvs are all the quantified tyvars
+           -- Hence the 'filter' in the ResTyH98 case only
         ; rdr_env <- getLocalRdrEnv
         ; let arg_tys    = hsConDeclArgTys details
-	      (free_kvs, free_tvs) = case res_ty of
-	      	    	       	       ResTyH98 -> filterInScope rdr_env (get_rdr_tvs arg_tys)
-	      	    	       	       ResTyGADT ty -> get_rdr_tvs (ty : arg_tys)
+              (free_kvs, free_tvs) = case res_ty of
+                                     ResTyH98 -> filterInScope rdr_env (get_rdr_tvs arg_tys)
+                                     ResTyGADT ty -> get_rdr_tvs (ty : arg_tys)
 
          -- With an Explicit forall, check for unused binders
-	 -- With Implicit, find the mentioned ones, and use them as binders
-	; new_tvs <- case expl of
-	    	       Implicit -> return (mkHsQTvs (userHsTyVarBndrs loc free_tvs))
-            	       Explicit -> do { warnUnusedForAlls (docOfHsDocContext doc) tvs free_tvs
+         -- With Implicit, find the mentioned ones, and use them as binders
+        ; new_tvs <- case expl of
+                       Implicit -> return (mkHsQTvs (userHsTyVarBndrs loc free_tvs))
+                       Explicit -> do { warnUnusedForAlls (docOfHsDocContext doc) tvs free_tvs
                                       ; return tvs }
 
-        ; mb_doc' <- rnMbLHsDoc mb_doc 
+        ; mb_doc' <- rnMbLHsDoc mb_doc
 
         ; bindHsTyVars doc Nothing free_kvs new_tvs $ \new_tyvars -> do
-	{ (new_context, fvs1) <- rnContext doc lcxt
-	; (new_details, fvs2) <- rnConDeclDetails doc details
+        { (new_context, fvs1) <- rnContext doc lcxt
+        ; (new_details, fvs2) <- rnConDeclDetails doc details
         ; (new_details', new_res_ty, fvs3) <- rnConResult doc (unLoc new_name) new_details res_ty
-        ; return (decl { con_name = new_name, con_qvars = new_tyvars, con_cxt = new_context 
+        ; return (decl { con_name = new_name, con_qvars = new_tyvars, con_cxt = new_context
                        , con_details = new_details', con_res = new_res_ty, con_doc = mb_doc' },
                   fvs1 `plusFV` fvs2 `plusFV` fvs3) }}
  where
@@ -1126,22 +1117,22 @@ rnConResult _   _   details ResTyH98 = return (details, ResTyH98, emptyFVs)
 rnConResult doc con details (ResTyGADT ty)
   = do { (ty', fvs) <- rnLHsType doc ty
        ; let (arg_tys, res_ty) = splitHsFunType ty'
-          	-- We can finally split it up, 
-		-- now the renamer has dealt with fixities
-	        -- See Note [Sorting out the result type] in RdrHsSyn
+                -- We can finally split it up,
+                -- now the renamer has dealt with fixities
+                -- See Note [Sorting out the result type] in RdrHsSyn
 
        ; case details of
-	   InfixCon {}  -> pprPanic "rnConResult" (ppr ty)
-	   -- See Note [Sorting out the result type] in RdrHsSyn
+           InfixCon {}  -> pprPanic "rnConResult" (ppr ty)
+           -- See Note [Sorting out the result type] in RdrHsSyn
 
-       	   RecCon {}    -> do { unless (null arg_tys) 
+           RecCon {}    -> do { unless (null arg_tys)
                                        (addErr (badRecResTy (docOfHsDocContext doc)))
                               ; return (details, ResTyGADT res_ty, fvs) }
 
-	   PrefixCon {} | isSymOcc (getOccName con)  -- See Note [Infix GADT cons]
+           PrefixCon {} | isSymOcc (getOccName con)  -- See Note [Infix GADT cons]
                         , [ty1,ty2] <- arg_tys
                         -> do { fix_env <- getFixityEnv
-                              ; return (if   con `elemNameEnv` fix_env 
+                              ; return (if   con `elemNameEnv` fix_env
                                         then InfixCon ty1 ty2
                                         else PrefixCon arg_tys
                                        , ResTyGADT res_ty, fvs) }
@@ -1161,30 +1152,30 @@ rnConDeclDetails doc (InfixCon ty1 ty2)
        ; return (InfixCon new_ty1 new_ty2, fvs1 `plusFV` fvs2) }
 
 rnConDeclDetails doc (RecCon fields)
-  = do	{ (new_fields, fvs) <- rnConDeclFields doc fields
-		-- No need to check for duplicate fields
-		-- since that is done by RnNames.extendGlobalRdrEnvRn
-	; return (RecCon new_fields, fvs) }
+  = do  { (new_fields, fvs) <- rnConDeclFields doc fields
+                -- No need to check for duplicate fields
+                -- since that is done by RnNames.extendGlobalRdrEnvRn
+        ; return (RecCon new_fields, fvs) }
 
 -------------------------------------------------
 deprecRecSyntax :: ConDecl RdrName -> SDoc
-deprecRecSyntax decl 
+deprecRecSyntax decl
   = vcat [ ptext (sLit "Declaration of") <+> quotes (ppr (con_name decl))
-    	 	 <+> ptext (sLit "uses deprecated syntax")
+                 <+> ptext (sLit "uses deprecated syntax")
          , ptext (sLit "Instead, use the form")
-         , nest 2 (ppr decl) ]	 -- Pretty printer uses new form
+         , nest 2 (ppr decl) ]   -- Pretty printer uses new form
 
 badRecResTy :: SDoc -> SDoc
 badRecResTy doc = ptext (sLit "Malformed constructor signature") $$ doc
 
 -- This data decl will parse OK
---	data T = a Int
+--      data T = a Int
 -- treating "a" as the constructor.
 -- It is really hard to make the parser spot this malformation.
 -- So the renamer has to check that the constructor is legal
 --
 -- We can get an operator as the constructor, even in the prefix form:
---	data T = :% Int Int
+--      data T = :% Int Int
 -- from interface files, which always print in prefix form
 
 checkConName :: RdrName -> TcRn ()
@@ -1204,14 +1195,14 @@ ad-hoc solution, we regard a GADT data constructor as infix if
   b) it has two arguments
   c) there is a fixity declaration for it
 For example:
-   infix 6 (:--:) 
+   infix 6 (:--:)
    data T a where
      (:--:) :: t1 -> t2 -> T Int
 
 %*********************************************************
-%*							*
+%*                                                      *
 \subsection{Support code for type/data declarations}
-%*							*
+%*                                                      *
 %*********************************************************
 
 Get the mapping from constructors to fields for this module.
@@ -1219,9 +1210,9 @@ It's convenient to do this after the data type decls have been renamed
 \begin{code}
 extendRecordFieldEnv :: [[LTyClDecl RdrName]] -> [LInstDecl RdrName] -> TcM TcGblEnv
 extendRecordFieldEnv tycl_decls inst_decls
-  = do	{ tcg_env <- getGblEnv
-	; field_env' <- foldrM get_con (tcg_field_env tcg_env) all_data_cons
-	; return (tcg_env { tcg_field_env = field_env' }) }
+  = do  { tcg_env <- getGblEnv
+        ; field_env' <- foldrM get_con (tcg_field_env tcg_env) all_data_cons
+        ; return (tcg_env { tcg_field_env = field_env' }) }
   where
     -- we want to lookup:
     --  (a) a datatype constructor
@@ -1234,24 +1225,24 @@ extendRecordFieldEnv tycl_decls inst_decls
 
     all_data_cons :: [ConDecl RdrName]
     all_data_cons = [con | TyData { td_cons = cons } <- all_ty_defs
-    		         , L _ con <- cons ]
+                         , L _ con <- cons ]
     all_ty_defs = [ defn | L _ (TyDecl { tcdTyDefn = defn }) <- concat tycl_decls ]
                ++ map fid_defn (instDeclFamInsts inst_decls)  -- Do not forget associated types!
 
     get_con (ConDecl { con_name = con, con_details = RecCon flds })
-	    (RecFields env fld_set)
-	= do { con' <- lookup con
+            (RecFields env fld_set)
+        = do { con' <- lookup con
              ; flds' <- mapM lookup (map cd_fld_name flds)
-	     ; let env'    = extendNameEnv env con' flds'
-	           fld_set' = addListToNameSet fld_set flds'
+             ; let env'    = extendNameEnv env con' flds'
+                   fld_set' = addListToNameSet fld_set flds'
              ; return $ (RecFields env' fld_set') }
     get_con _ env = return env
 \end{code}
 
 %*********************************************************
-%*							*
+%*                                                      *
 \subsection{Support code to rename types}
-%*							*
+%*                                                      *
 %*********************************************************
 
 \begin{code}
@@ -1261,9 +1252,9 @@ rnFds doc fds
   = mapM (wrapLocM rn_fds) fds
   where
     rn_fds (tys1, tys2)
-      =	do { tys1' <- rnHsTyVars doc tys1
-	   ; tys2' <- rnHsTyVars doc tys2
-	   ; return (tys1', tys2') }
+      = do { tys1' <- rnHsTyVars doc tys1
+           ; tys2' <- rnHsTyVars doc tys2
+           ; return (tys1', tys2') }
 
 rnHsTyVars :: SDoc -> [RdrName] -> RnM [Name]
 rnHsTyVars doc tvs  = mapM (rnHsTyVar doc) tvs
@@ -1274,15 +1265,15 @@ rnHsTyVar _doc tyvar = lookupOccRn tyvar
 
 
 %*********************************************************
-%*							*
-	findSplice
-%*							*
+%*                                                      *
+        findSplice
+%*                                                      *
 %*********************************************************
 
 This code marches down the declarations, looking for the first
 Template Haskell splice.  As it does so it
-	a) groups the declarations into a HsGroup
-	b) runs any top-level quasi-quotes
+        a) groups the declarations into a HsGroup
+        b) runs any top-level quasi-quotes
 
 \begin{code}
 findSplice :: [LHsDecl RdrName] -> RnM (HsGroup RdrName, Maybe (SpliceDecl RdrName, [LHsDecl RdrName]))
@@ -1291,15 +1282,15 @@ findSplice ds = addl emptyRdrGroup ds
 addl :: HsGroup RdrName -> [LHsDecl RdrName]
      -> RnM (HsGroup RdrName, Maybe (SpliceDecl RdrName, [LHsDecl RdrName]))
 -- This stuff reverses the declarations (again) but it doesn't matter
-addl gp []	     = return (gp, Nothing)
+addl gp []           = return (gp, Nothing)
 addl gp (L l d : ds) = add gp l d ds
 
 
 add :: HsGroup RdrName -> SrcSpan -> HsDecl RdrName -> [LHsDecl RdrName]
     -> RnM (HsGroup RdrName, Maybe (SpliceDecl RdrName, [LHsDecl RdrName]))
 
-add gp loc (SpliceD splice@(SpliceDecl _ flag)) ds 
-  = do { -- We've found a top-level splice.  If it is an *implicit* one 
+add gp loc (SpliceD splice@(SpliceDecl _ flag)) ds
+  = do { -- We've found a top-level splice.  If it is an *implicit* one
          -- (i.e. a naked top level expression)
          case flag of
            Explicit -> return ()
@@ -1315,7 +1306,7 @@ add gp loc (SpliceD splice@(SpliceDecl _ flag)) ds
 add _ _ (QuasiQuoteD qq) _
   = pprPanic "Can't do QuasiQuote declarations without GHCi" (ppr qq)
 #else
-add gp _ (QuasiQuoteD qq) ds		-- Expand quasiquotes
+add gp _ (QuasiQuoteD qq) ds            -- Expand quasiquotes
   = do { ds' <- runQuasiQuoteDecl qq
        ; addl gp (ds' ++ ds) }
 #endif
@@ -1367,6 +1358,6 @@ add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs
 add_bind _ (ValBindsOut {})     = panic "RdrHsSyn:add_bind"
 
 add_sig :: LSig a -> HsValBinds a -> HsValBinds a
-add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs) 
+add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs)
 add_sig _ (ValBindsOut {})     = panic "RdrHsSyn:add_sig"
 \end{code}
diff --git a/compiler/simplStg/SRT.lhs b/compiler/simplStg/SRT.lhs
deleted file mode 100644
index 92cfad3283..0000000000
--- a/compiler/simplStg/SRT.lhs
+++ /dev/null
@@ -1,166 +0,0 @@
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1998
-%
-
-Run through the STG code and compute the Static Reference Table for
-each let-binding.  At the same time, we figure out which top-level
-bindings have no CAF references, and record the fact in their IdInfo.
-
-\begin{code}
-module SRT( computeSRTs ) where
-
-#include "HsVersions.h"
-
-import StgSyn
-import Id               ( Id )
-import VarSet
-import VarEnv
-import Maybes           ( orElse, expectJust )
-import Bitmap
-
-import DynFlags
-import Outputable
-
-import Data.List
-\end{code}
-
-\begin{code}
-computeSRTs :: DynFlags -> [StgBinding] -> [(StgBinding,[(Id,[Id])])]
-  -- The incoming bindingd are filled with SRTEntries in their SRT slots
-  -- the outgoing ones have NoSRT/SRT values instead
-
-computeSRTs dflags binds = srtTopBinds dflags emptyVarEnv binds
-
--- --------------------------------------------------------------------------
--- Top-level Bindings
-
-srtTopBinds :: DynFlags -> IdEnv Id -> [StgBinding] -> [(StgBinding, [(Id,[Id])])]
-
-srtTopBinds _ _   [] = []
-srtTopBinds dflags env (StgNonRec b rhs : binds) =
-  (StgNonRec b rhs', [(b,srt')]) : srtTopBinds dflags env' binds
-  where
-    (rhs', srt) = srtTopRhs dflags b rhs
-    env' = maybeExtendEnv env b rhs
-    srt' = applyEnvList env srt
-srtTopBinds dflags env (StgRec bs : binds) =
-  (StgRec (zip bndrs rhss), zip bndrs srts') : srtTopBinds dflags env binds
-  where
-    (rhss, srts) = unzip [ srtTopRhs dflags b r | (b,r) <- bs ]
-    bndrs = map fst bs
-    srts' = map (applyEnvList env) srts
-
--- Shorting out indirections in SRTs:  if a binding has an SRT with a single
--- element in it, we just inline it with that element everywhere it occurs
--- in other SRTs.
---
--- This is in a way a generalisation of the CafInfo.  CafInfo says
--- whether a top-level binding has *zero* CAF references, allowing us
--- to omit it from SRTs.  Here, we pick up bindings with *one* CAF
--- reference, and inline its SRT everywhere it occurs.  We could pass
--- this information across module boundaries too, but we currently
--- don't.
-
-maybeExtendEnv ::IdEnv Id -> Id -> StgRhs -> IdEnv Id
-maybeExtendEnv env bndr (StgRhsClosure _ _ _ ReEntrant (SRTEntries cafs) _ _)
-  | [one] <- varSetElems cafs
-  = extendVarEnv env bndr (applyEnv env one)
-maybeExtendEnv env _ _ = env
-
-applyEnvList :: IdEnv Id -> [Id] -> [Id]
-applyEnvList env = map (applyEnv env)
-
-applyEnv :: IdEnv Id -> Id -> Id
-applyEnv env id = lookupVarEnv env id `orElse` id
-
--- ----  Top-level right hand sides:
-
-srtTopRhs :: DynFlags -> Id -> StgRhs -> (StgRhs, [Id])
-
-srtTopRhs _ _ rhs@(StgRhsCon _ _ _) = (rhs, [])
-srtTopRhs dflags _ rhs@(StgRhsClosure _ _ _ _  (SRTEntries cafs) _ _)
-  = (srtRhs dflags table rhs, elems)
-  where
-        elems = varSetElems cafs
-        table = mkVarEnv (zip elems [0..])
-srtTopRhs _ _ (StgRhsClosure _ _ _ _  NoSRT _ _) = panic "srtTopRhs NoSRT"
-srtTopRhs _ _ (StgRhsClosure _ _ _ _  (SRT _ _ _) _ _) = panic "srtTopRhs SRT"
-
--- ---- Binds:
-
-srtBind :: DynFlags -> IdEnv Int -> StgBinding -> StgBinding
-
-srtBind dflags table (StgNonRec binder rhs) = StgNonRec binder (srtRhs dflags table rhs)
-srtBind dflags table (StgRec pairs) = StgRec [ (b, srtRhs dflags table r) | (b,r) <- pairs ]
-
--- ---- Right Hand Sides:
-
-srtRhs :: DynFlags -> IdEnv Int -> StgRhs -> StgRhs
-
-srtRhs _      _     e@(StgRhsCon _ _ _) = e
-srtRhs dflags table (StgRhsClosure cc bi free_vars u srt args body)
-  = StgRhsClosure cc bi free_vars u (constructSRT dflags table srt) args
-        $! (srtExpr dflags table body)
-
--- ---------------------------------------------------------------------------
--- Expressions
-
-srtExpr :: DynFlags -> IdEnv Int -> StgExpr -> StgExpr
-
-srtExpr _ _ e@(StgApp _ _)       = e
-srtExpr _ _ e@(StgLit _)         = e
-srtExpr _ _ e@(StgConApp _ _)    = e
-srtExpr _ _ e@(StgOpApp _ _ _)   = e
-
-srtExpr dflags table (StgSCC cc tick push expr) = StgSCC cc tick push $! srtExpr dflags table expr
-
-srtExpr dflags table (StgTick m n expr) = StgTick m n $! srtExpr dflags table expr
-
-srtExpr dflags table (StgCase scrut live1 live2 uniq srt alt_type alts)
- = StgCase expr' live1 live2 uniq srt' alt_type alts'
- where
-   expr' = srtExpr dflags table scrut
-   srt'  = constructSRT dflags table srt
-   alts' = map (srtAlt dflags table) alts
-
-srtExpr dflags table (StgLet bind body)
-  = srtBind dflags table bind =: \ bind' ->
-    srtExpr dflags table body             =: \ body' ->
-    StgLet bind' body'
-
-srtExpr dflags table (StgLetNoEscape live1 live2 bind body)
-  = srtBind dflags table bind =: \ bind' ->
-    srtExpr dflags table body             =: \ body' ->
-    StgLetNoEscape live1 live2 bind' body'
-
-srtExpr _ _table expr = pprPanic "srtExpr" (ppr expr)
-
-srtAlt :: DynFlags -> IdEnv Int -> StgAlt -> StgAlt
-srtAlt dflags table (con,args,used,rhs)
-  = (,,,) con args used $! srtExpr dflags table rhs
-
------------------------------------------------------------------------------
--- Construct an SRT bitmap.
-
-constructSRT :: DynFlags -> IdEnv Int -> SRT -> SRT
-constructSRT dflags table (SRTEntries entries)
- | isEmptyVarSet entries = NoSRT
- | otherwise  = seqBitmap bitmap $ SRT offset len bitmap
-  where
-    ints = map (expectJust "constructSRT" . lookupVarEnv table)
-                (varSetElems entries)
-    sorted_ints = sort ints
-    offset = head sorted_ints
-    bitmap_entries = map (subtract offset) sorted_ints
-    len = last bitmap_entries + 1
-    bitmap = intsToBitmap dflags len bitmap_entries
-constructSRT _ _ NoSRT = panic "constructSRT NoSRT"
-constructSRT _ _ (SRT {}) = panic "constructSRT SRT"
-
--- ---------------------------------------------------------------------------
--- Misc stuff
-
-(=:) :: a -> (a -> b) -> b
-a =: k  = k a
-
-\end{code}
diff --git a/compiler/simplStg/SimplStg.lhs b/compiler/simplStg/SimplStg.lhs
index 129d8c6423..871a5f4960 100644
--- a/compiler/simplStg/SimplStg.lhs
+++ b/compiler/simplStg/SimplStg.lhs
@@ -22,12 +22,10 @@ import SCCfinal		( stgMassageForProfiling )
 import StgLint		( lintStgBindings )
 import StgStats	        ( showStgStats )
 import UnariseStg       ( unarise )
-import SRT		( computeSRTs )
 
 import DynFlags		( DynFlags(..), DynFlag(..), dopt, StgToDo(..),
 			  getStgToDo )
-import Id		( Id )
-import Module		( Module )
+import Module           ( Module )
 import ErrUtils
 import SrcLoc
 import UniqSupply	( mkSplitUniqSupply, splitUniqSupply )
@@ -38,7 +36,7 @@ import Outputable
 stg2stg :: DynFlags		     -- includes spec of what stg-to-stg passes to do
 	-> Module		     -- module name (profiling only)
 	-> [StgBinding]		     -- input...
-	-> IO ( [(StgBinding,[(Id,[Id])])]  -- output program...
+        -> IO ( [StgBinding]  -- output program...
 	      , CollectedCCs)        -- cost centre information (declared and used)
 
 stg2stg dflags module_name binds
@@ -56,14 +54,11 @@ stg2stg dflags module_name binds
 		<- foldl_mn do_stg_pass (binds', us0, ccs) (getStgToDo dflags)
 
         ; let un_binds = unarise us1 processed_binds
-        ; let srt_binds
-               | dopt Opt_TryNewCodeGen dflags = zip un_binds (repeat [])
-               | otherwise = computeSRTs dflags un_binds
 
 	; dumpIfSet_dyn dflags Opt_D_dump_stg "STG syntax:" 
-	     		(pprStgBindingsWithSRTs srt_binds)
+                        (pprStgBindings un_binds)
 
-	; return (srt_binds, cost_centres)
+        ; return (un_binds, cost_centres)
    }
 
   where
diff --git a/compiler/stgSyn/StgSyn.lhs b/compiler/stgSyn/StgSyn.lhs
index e5c525e4c3..8d00f94ead 100644
--- a/compiler/stgSyn/StgSyn.lhs
+++ b/compiler/stgSyn/StgSyn.lhs
@@ -38,7 +38,7 @@ module StgSyn (
         isDllConApp,
         stgArgType,
 
-        pprStgBinding, pprStgBindings, pprStgBindingsWithSRTs,
+        pprStgBinding, pprStgBindings,
         pprStgLVs
     ) where
 
@@ -651,16 +651,6 @@ pprStgBinding  bind  = pprGenStgBinding bind
 pprStgBindings :: [StgBinding] -> SDoc
 pprStgBindings binds = vcat (map pprGenStgBinding binds)
 
-pprGenStgBindingWithSRT :: (OutputableBndr bndr, Outputable bdee, Ord bdee)
-                        => (GenStgBinding bndr bdee,[(Id,[Id])]) -> SDoc
-pprGenStgBindingWithSRT (bind,srts)
-  = vcat $ pprGenStgBinding bind : map pprSRT srts
-  where pprSRT (id,srt) =
-           ptext (sLit "SRT") <> parens (ppr id) <> ptext (sLit ": ") <> ppr srt
-
-pprStgBindingsWithSRTs :: [(StgBinding,[(Id,[Id])])] -> SDoc
-pprStgBindingsWithSRTs binds = vcat (map pprGenStgBindingWithSRT binds)
-
 instance (Outputable bdee) => Outputable (GenStgArg bdee) where
     ppr = pprStgArg
 
diff --git a/compiler/typecheck/TcGenGenerics.lhs b/compiler/typecheck/TcGenGenerics.lhs
index 8745f8e612..fbb600c463 100644
--- a/compiler/typecheck/TcGenGenerics.lhs
+++ b/compiler/typecheck/TcGenGenerics.lhs
@@ -224,7 +224,7 @@ canDoGenerics tc tc_args
     (tc_name, tc_tys) = case tyConParent tc of
         FamInstTyCon _ ptc tys -> (ppr ptc, hsep (map ppr
                                             (tys ++ drop (length tys) tc_args)))
-        _                      -> (ppr tc, hsep (map ppr tc_args))
+        _                      -> (ppr tc, hsep (map ppr (tyConTyVars tc)))
 
         -- If any of the constructor has an unboxed type as argument,
         -- then we can't build the embedding-projection pair, because
diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs
index 610ef45178..c40a9f725b 100644
--- a/compiler/typecheck/TcRnMonad.lhs
+++ b/compiler/typecheck/TcRnMonad.lhs
@@ -283,16 +283,16 @@ unsetWOptM flag = updEnv (\ env@(Env { env_top = top }) ->
 
 -- | Do it flag is true
 ifDOptM :: DynFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
-ifDOptM flag thing_inside = do { b <- doptM flag ;
-                                if b then thing_inside else return () }
+ifDOptM flag thing_inside = do b <- doptM flag
+                               when b thing_inside
 
 ifWOptM :: WarningFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
-ifWOptM flag thing_inside = do { b <- woptM flag ;
-                                if b then thing_inside else return () }
+ifWOptM flag thing_inside = do b <- woptM flag
+                               when b thing_inside
 
 ifXOptM :: ExtensionFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
-ifXOptM flag thing_inside = do { b <- xoptM flag ;
-                                if b then thing_inside else return () }
+ifXOptM flag thing_inside = do b <- xoptM flag
+                               when b thing_inside
 
 getGhcMode :: TcRnIf gbl lcl GhcMode
 getGhcMode = do { env <- getTopEnv; return (ghcMode (hsc_dflags env)) }
diff --git a/compiler/utils/Bag.lhs b/compiler/utils/Bag.lhs
index a32991b97d..a83397898e 100644
--- a/compiler/utils/Bag.lhs
+++ b/compiler/utils/Bag.lhs
@@ -268,5 +268,6 @@ instance Data a => Data (Bag a) where
   toConstr _   = abstractConstr $ "Bag("++show (typeOf (undefined::a))++")"
   gunfold _ _  = error "gunfold"
   dataTypeOf _ = mkNoRepType "Bag"
+  dataCast1 x  = gcast1 x
 \end{code}
 
diff --git a/compiler/utils/Serialized.hs b/compiler/utils/Serialized.hs
index 26cca6c386..902d2feea0 100644
--- a/compiler/utils/Serialized.hs
+++ b/compiler/utils/Serialized.hs
@@ -95,16 +95,26 @@ deserializeConstr bytes k = deserializeWord8 bytes $ \constr_ix bytes ->
                                 x -> error $ "deserializeConstr: unrecognised serialized constructor type " ++ show x ++ " in context " ++ show bytes
 
 
+#if __GLASGOW_HASKELL__ < 707
 serializeFixedWidthNum :: forall a. (Num a, Integral a, Bits a) => a -> [Word8] -> [Word8]
 serializeFixedWidthNum what = go (bitSize what) what
+#else
+serializeFixedWidthNum :: forall a. (Num a, Integral a, FiniteBits a) => a -> [Word8] -> [Word8]
+serializeFixedWidthNum what = go (finiteBitSize what) what
+#endif
   where
     go :: Int -> a -> [Word8] -> [Word8]
     go size current rest
       | size <= 0 = rest
       | otherwise = fromIntegral (current .&. 255) : go (size - 8) (current `shiftR` 8) rest
 
+#if __GLASGOW_HASKELL__ < 707
 deserializeFixedWidthNum :: forall a b. (Num a, Integral a, Bits a) => [Word8] -> (a -> [Word8] -> b) -> b
 deserializeFixedWidthNum bytes k = go (bitSize (undefined :: a)) bytes k
+#else
+deserializeFixedWidthNum :: forall a b. (Num a, Integral a, FiniteBits a) => [Word8] -> (a -> [Word8] -> b) -> b
+deserializeFixedWidthNum bytes k = go (finiteBitSize (undefined :: a)) bytes k
+#endif
   where
     go :: Int -> [Word8] -> (a -> [Word8] -> b) -> b
     go size bytes k