Merge branch 'master' of darcs.haskell.org:/srv/darcs//ghc

33 files changed, 1003 insertions, 528 deletions

diff --git a/compiler/cmm/CmmBuildInfoTables.hs b/compiler/cmm/CmmBuildInfoTables.hs
index ebe755219b..651cc6f40f 100644
--- a/compiler/cmm/CmmBuildInfoTables.hs
+++ b/compiler/cmm/CmmBuildInfoTables.hs
@@ -13,17 +13,15 @@
 -- Todo: remove -fno-warn-warnings-deprecations
 {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
 module CmmBuildInfoTables
-    ( CAFSet, CAFEnv, cafAnal, localCAFInfo, mkTopCAFInfo
-    , setInfoTableSRT
-    , TopSRT, emptySRT, srtToData
-    , bundleCAFs
-    , cafTransfers )
+    ( CAFSet, CAFEnv, cafAnal
+    , doSRTs, TopSRT, emptySRT, srtToData )
 where
 
 #include "HsVersions.h"
 
 -- These should not be imported here!
 import StgCmmUtils
+import Hoopl
 
 import Digraph
 import qualified Prelude as P
@@ -41,13 +39,13 @@ import Name
 import Outputable
 import SMRep
 import UniqSupply
-
-import Hoopl
+import Util
 
 import Data.Map (Map)
 import qualified Data.Map as Map
 import Data.Set (Set)
 import qualified Data.Set as Set
+import Control.Monad
 
 foldSet :: (a -> b -> b) -> b -> Set a -> b
 #if __GLASGOW_HASKELL__ < 704
@@ -71,6 +69,44 @@ foldSet = Set.foldr
 -- THE CLOSURE AND INLINE THEM INTO ANY SRT THAT MAY MENTION THE CLOSURE.
 -- (I.E. TAKE THE TRANSITIVE CLOSURE, but only for non-static closures).
 
+{- EXAMPLE
+
+f = \x. ... g ...
+  where
+    g = \y. ... h ... c1 ...
+    h = \z. ... c2 ...
+
+c1 & c2 are CAFs
+
+g and h are local functions, but they have no static closures.  When
+we generate code for f, we start with a CmmGroup of four CmmDecls:
+
+   [ f_closure, f_entry, g_entry, h_entry ]
+
+we process each CmmDecl separately in cpsTop, giving us a list of
+CmmDecls. e.g. for f_entry, we might end up with
+
+   [ f_entry, f1_ret, f2_proc ]
+
+where f1_ret is a return point, and f2_proc is a proc-point.  We have
+a CAFSet for each of these CmmDecls, let's suppose they are
+
+   [ f_entry{g_closure}, f1_ret{g_closure}, f2_proc{} ]
+   [ g_entry{h_closure, c1_closure} ]
+   [ h_entry{c2_closure} ]
+
+Now, note that we cannot use g_closure and h_closure in an SRT,
+because there are no static closures corresponding to these functions.
+So we have to flatten out the structure, replacing g_closure and
+h_closure with their contents:
+
+   [ f_entry{c2_closure, c1_closure}, f1_ret{c2_closure,c1_closure}, f2_proc{} ]
+   [ g_entry{c2_closure, c1_closure} ]
+   [ h_entry{c2_closure} ]
+
+This is what mkTopCAFInfo is doing.
+
+-}
 
 -----------------------------------------------------------------------
 -- Finding the CAFs used by a procedure
@@ -147,16 +183,13 @@ srtToData srt = [CmmData RelocatableReadOnlyData (Statics (lbl srt) tbl)]
 -- in the SRT. Then, if the number of CAFs is small enough to fit in a bitmap,
 -- we make sure they're all close enough to the bottom of the table that the
 -- bitmap will be able to cover all of them.
-buildSRTs :: TopSRT -> Map CLabel CAFSet -> CAFSet ->
-             UniqSM (TopSRT, Maybe CmmDecl, C_SRT)
-buildSRTs topSRT topCAFMap cafs =
-  do let liftCAF lbl z = -- get CAFs for functions without static closures
-           case Map.lookup lbl topCAFMap of Just cafs -> z `Set.union` cafs
-                                            Nothing   -> Set.insert lbl z
+buildSRTs :: TopSRT -> CAFSet -> UniqSM (TopSRT, Maybe CmmDecl, C_SRT)
+buildSRTs topSRT cafs =
+  do let
          -- For each label referring to a function f without a static closure,
          -- replace it with the CAFs that are reachable from f.
          sub_srt topSRT localCafs =
-           let cafs = Set.elems (foldSet liftCAF Set.empty localCafs)
+           let cafs = Set.elems localCafs
                mkSRT topSRT =
                  do localSRTs <- procpointSRT (lbl topSRT) (elt_map topSRT) cafs
                     return (topSRT, localSRTs)
@@ -230,15 +263,15 @@ to_SRT top_srt off len bmp
 --  keep its CAFs live.)
 -- Any procedure referring to a non-static CAF c must keep live
 -- any CAF that is reachable from c.
-localCAFInfo :: CAFEnv -> CmmDecl -> Maybe (CLabel, CAFSet)
-localCAFInfo _      (CmmData _ _) = Nothing
+localCAFInfo :: CAFEnv -> CmmDecl -> (CAFSet, Maybe CLabel)
+localCAFInfo _      (CmmData _ _) = (Set.empty, Nothing)
 localCAFInfo cafEnv (CmmProc top_info top_l (CmmGraph {g_entry=entry})) =
   case info_tbl top_info of
-    CmmInfoTable { cit_rep = rep } 
-      | not (isStaticRep rep) 
-      -> Just (toClosureLbl top_l,
-               expectJust "maybeBindCAFs" $ mapLookup entry cafEnv)
-    _ -> Nothing
+    CmmInfoTable { cit_rep = rep } | not (isStaticRep rep)
+      -> (cafs, Just (toClosureLbl top_l))
+    _other -> (cafs, Nothing)
+  where
+    cafs = expectJust "maybeBindCAFs" $ mapLookup entry cafEnv
 
 -- Once we have the local CAF sets for some (possibly) mutually
 -- recursive functions, we can create an environment mapping
@@ -251,54 +284,77 @@ localCAFInfo cafEnv (CmmProc top_info top_l (CmmGraph {g_entry=entry})) =
 -- the environment with every reference to f replaced by its set of CAFs.
 -- To do this replacement efficiently, we gather strongly connected
 -- components, then we sort the components in topological order.
-mkTopCAFInfo :: [(CLabel, CAFSet)] -> Map CLabel CAFSet
+mkTopCAFInfo :: [(CAFSet, Maybe CLabel)] -> Map CLabel CAFSet
 mkTopCAFInfo localCAFs = foldl addToTop Map.empty g
-  where addToTop env (AcyclicSCC (l, cafset)) =
+  where
+        addToTop env (AcyclicSCC (l, cafset)) =
           Map.insert l (flatten env cafset) env
         addToTop env (CyclicSCC nodes) =
           let (lbls, cafsets) = unzip nodes
               cafset  = foldr Set.delete (foldl Set.union Set.empty cafsets) lbls
           in foldl (\env l -> Map.insert l (flatten env cafset) env) env lbls
-        flatten env cafset = foldSet (lookup env) Set.empty cafset
-        lookup env caf cafset' =
-          case Map.lookup caf env of Just cafs -> foldSet add cafset' cafs
-                                     Nothing -> add caf cafset'
-        add caf cafset' = Set.insert caf cafset'
+
         g = stronglyConnCompFromEdgedVertices
-              (map (\n@(l, cafs) -> (n, l, Set.elems cafs)) localCAFs)
-
--- Bundle the CAFs used at a procpoint.
-bundleCAFs :: CAFEnv -> CmmDecl -> (CAFSet, CmmDecl)
-bundleCAFs cafEnv t@(CmmProc _ _ (CmmGraph {g_entry=entry})) =
-  (expectJust "bundleCAFs" (mapLookup entry cafEnv), t)
-bundleCAFs _ t = (Set.empty, t)
-
--- Construct the SRTs for the given procedure.
-setInfoTableSRT :: Map CLabel CAFSet -> TopSRT -> (CAFSet, CmmDecl) ->
-                   UniqSM (TopSRT, [CmmDecl])
-setInfoTableSRT topCAFMap topSRT (cafs, t) =
-  setSRT cafs topCAFMap topSRT t
-
-setSRT :: CAFSet -> Map CLabel CAFSet -> TopSRT ->
-          CmmDecl -> UniqSM (TopSRT, [CmmDecl])
-setSRT cafs topCAFMap topSRT t =
-  do (topSRT, cafTable, srt) <- buildSRTs topSRT topCAFMap cafs
-     let t' = updInfo id (const srt) t
-     case cafTable of
-       Just tbl -> return (topSRT, [t', tbl])
-       Nothing  -> return (topSRT, [t'])
-
-type StackLayout = Liveness
-
-updInfo :: (StackLayout -> StackLayout) -> (C_SRT -> C_SRT) -> CmmDecl -> CmmDecl
-updInfo toVars toSrt (CmmProc top_info top_l g) =
-  CmmProc (top_info {info_tbl=updInfoTbl toVars toSrt (info_tbl top_info)}) top_l g
-updInfo _ _ t = t
-
-updInfoTbl :: (StackLayout -> StackLayout) -> (C_SRT -> C_SRT) -> CmmInfoTable -> CmmInfoTable
-updInfoTbl toVars toSrt info_tbl@(CmmInfoTable {})
-  = info_tbl { cit_srt = toSrt (cit_srt info_tbl)
-             , cit_rep = case cit_rep info_tbl of
-                           StackRep ls -> StackRep (toVars ls)
-                           other       -> other }
-updInfoTbl _ _ t@CmmNonInfoTable = t
+              [ ((l,cafs), l, Set.elems cafs) | (cafs, Just l) <- localCAFs ]
+
+flatten :: Map CLabel CAFSet -> CAFSet -> CAFSet
+flatten env cafset = foldSet (lookup env) Set.empty cafset
+  where
+      lookup env caf cafset' =
+          case Map.lookup caf env of
+             Just cafs -> foldSet Set.insert cafset' cafs
+             Nothing   -> Set.insert caf cafset'
+
+bundle :: Map CLabel CAFSet
+       -> (CAFEnv, CmmDecl)
+       -> (CAFSet, Maybe CLabel)
+       -> (CAFSet, CmmDecl)
+bundle flatmap (_, decl) (cafs, Nothing)
+  = (flatten flatmap cafs, decl)
+bundle flatmap (_, decl) (_, Just l)
+  = (expectJust "bundle" $ Map.lookup l flatmap, decl)
+
+flattenCAFSets :: [(CAFEnv, [CmmDecl])] -> [(CAFSet, CmmDecl)]
+flattenCAFSets cpsdecls = zipWith (bundle flatmap) zipped localCAFs
+   where
+     zipped    = [(e,d) | (e,ds) <- cpsdecls, d <- ds ]
+     localCAFs = unzipWith localCAFInfo zipped
+     flatmap   = mkTopCAFInfo localCAFs -- transitive closure of localCAFs
+
+doSRTs :: TopSRT
+       -> [(CAFEnv, [CmmDecl])]
+       -> IO (TopSRT, [CmmDecl])
+
+doSRTs topSRT tops
+  = do
+     let caf_decls = flattenCAFSets tops
+     us <- mkSplitUniqSupply 'u'
+     let (topSRT', gs') = initUs_ us $ foldM setSRT (topSRT, []) caf_decls
+     return (topSRT', reverse gs' {- Note [reverse gs] -})
+  where
+    setSRT (topSRT, rst) (cafs, decl@(CmmProc{})) = do
+       (topSRT, cafTable, srt) <- buildSRTs topSRT cafs
+       let decl' = updInfo (const srt) decl
+       case cafTable of
+         Just tbl -> return (topSRT, decl': tbl : rst)
+         Nothing  -> return (topSRT, decl' : rst)
+    setSRT (topSRT, rst) (_, decl) =
+      return (topSRT, decl : rst)
+
+{- Note [reverse gs]
+
+   It is important to keep the code blocks in the same order,
+   otherwise binary sizes get slightly bigger.  I'm not completely
+   sure why this is, perhaps the assembler generates bigger jump
+   instructions for forward refs.  --SDM
+-}
+
+updInfo :: (C_SRT -> C_SRT) -> CmmDecl -> CmmDecl
+updInfo toSrt (CmmProc top_info top_l g) =
+  CmmProc (top_info {info_tbl = updInfoTbl toSrt (info_tbl top_info)}) top_l g
+updInfo _ t = t
+
+updInfoTbl :: (C_SRT -> C_SRT) -> CmmInfoTable -> CmmInfoTable
+updInfoTbl toSrt info_tbl@(CmmInfoTable {})
+  = info_tbl { cit_srt = toSrt (cit_srt info_tbl) }
+updInfoTbl _ t@CmmNonInfoTable = t
diff --git a/compiler/cmm/CmmLayoutStack.hs b/compiler/cmm/CmmLayoutStack.hs
index 732fb2b849..d45c4d8546 100644
--- a/compiler/cmm/CmmLayoutStack.hs
+++ b/compiler/cmm/CmmLayoutStack.hs
@@ -3,7 +3,7 @@
 {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
 #endif
 module CmmLayoutStack (
-       cmmLayoutStack, setInfoTableStackMap, cmmSink
+       cmmLayoutStack, setInfoTableStackMap
   ) where
 
 import StgCmmUtils      ( callerSaveVolatileRegs ) -- XXX
@@ -34,7 +34,7 @@ import qualified Data.Set as Set
 import Control.Monad.Fix
 import Data.Array as Array
 import Data.Bits
-import Data.List (nub, partition)
+import Data.List (nub)
 import Control.Monad (liftM)
 
 #include "HsVersions.h"
@@ -111,20 +111,20 @@ cmmLayoutStack :: ProcPointSet -> ByteOff -> CmmGraph
 cmmLayoutStack procpoints entry_args
                graph0@(CmmGraph { g_entry = entry })
   = do
-    pprTrace "cmmLayoutStack" (ppr entry_args) $ return ()
+    -- pprTrace "cmmLayoutStack" (ppr entry_args) $ return ()
     (graph, liveness) <- removeDeadAssignments graph0
-    pprTrace "liveness" (ppr liveness) $ return ()
+    -- pprTrace "liveness" (ppr liveness) $ return ()
     let blocks = postorderDfs graph
 
-    (final_stackmaps, final_high_sp, new_blocks) <-
+    (final_stackmaps, _final_high_sp, new_blocks) <-
           mfix $ \ ~(rec_stackmaps, rec_high_sp, _new_blocks) ->
             layout procpoints liveness entry entry_args
                    rec_stackmaps rec_high_sp blocks
 
     new_blocks' <- mapM lowerSafeForeignCall new_blocks
 
-    pprTrace ("Sp HWM") (ppr final_high_sp) $
-       return (ofBlockList entry new_blocks', final_stackmaps)
+    -- pprTrace ("Sp HWM") (ppr _final_high_sp) $ return ()
+    return (ofBlockList entry new_blocks', final_stackmaps)
 
 
 
@@ -167,7 +167,7 @@ layout procpoints liveness entry entry_args final_stackmaps final_hwm blocks
                      (pprPanic "no stack map for" (ppr entry_lbl))
                      entry_lbl acc_stackmaps
     
-       pprTrace "layout" (ppr entry_lbl <+> ppr stack0) $ return ()
+       -- pprTrace "layout" (ppr entry_lbl <+> ppr stack0) $ return ()
     
        -- (a) Update the stack map to include the effects of
        --     assignments in this block
@@ -188,7 +188,7 @@ layout procpoints liveness entry entry_args final_stackmaps final_hwm blocks
            <- handleLastNode procpoints liveness cont_info
                              acc_stackmaps stack1 middle0 last0
     
-       pprTrace "layout(out)" (ppr out) $ return ()
+       -- pprTrace "layout(out)" (ppr out) $ return ()
 
        -- (d) Manifest Sp: run over the nodes in the block and replace
        --     CmmStackSlot with CmmLoad from Sp with a concrete offset.
@@ -416,8 +416,8 @@ handleLastNode procpoints liveness cont_info stackmaps
                   case mapLookup l stackmaps of
                     Just pp_sm -> (pp_sm, fixupStack stack0 pp_sm)
                     Nothing    ->
-                      pprTrace "first visit to proc point"
-                                   (ppr l <+> ppr stack1) $
+                      --pprTrace "first visit to proc point"
+                      --             (ppr l <+> ppr stack1) $
                       (stack1, assigs)
                       where
                        cont_args = mapFindWithDefault 0 l cont_info
@@ -570,7 +570,7 @@ allocate :: ByteOff -> RegSet -> StackMap -> (StackMap, [CmmNode O O])
 allocate ret_off live stackmap@StackMap{ sm_sp = sp0
                                        , sm_regs = regs0 }
  =
-  pprTrace "allocate" (ppr live $$ ppr stackmap) $
+  -- pprTrace "allocate" (ppr live $$ ppr stackmap) $
 
    -- we only have to save regs that are not already in a slot
    let to_save = filter (not . (`elemUFM` regs0)) (Set.elems live)
@@ -798,7 +798,8 @@ elimStackStores stackmap stackmaps area_off nodes
          CmmStore (CmmStackSlot area m) (CmmReg (CmmLocal r))
             | Just (_,off) <- lookupUFM (sm_regs stackmap) r
             , area_off area + m == off
-            -> pprTrace "eliminated a node!" (ppr r) $ go stackmap ns
+            -> -- pprTrace "eliminated a node!" (ppr r) $
+               go stackmap ns
          _otherwise
             -> n : go (procMiddle stackmaps n stackmap) ns
 
@@ -978,75 +979,3 @@ insertReloads stackmap =
 stackSlotRegs :: StackMap -> [(LocalReg, StackLoc)]
 stackSlotRegs sm = eltsUFM (sm_regs sm)
 
--- -----------------------------------------------------------------------------
-
--- If we do this *before* stack layout, we might be able to avoid
--- saving some things across calls/procpoints.
---
--- *but*, that will invalidate the liveness analysis, and we'll have
--- to re-do it.
-
-cmmSink :: CmmGraph -> UniqSM CmmGraph
-cmmSink graph = do
-  let liveness = cmmLiveness graph
-  return $ cmmSink' liveness graph
-
-cmmSink' :: BlockEnv CmmLive -> CmmGraph -> CmmGraph
-cmmSink' liveness graph
-  = ofBlockList (g_entry graph) $ sink mapEmpty $ postorderDfs graph
-  where
-
-  sink :: BlockEnv [(LocalReg, CmmExpr)] -> [CmmBlock] -> [CmmBlock]
-  sink _ [] = []
-  sink sunk (b:bs) =
-    pprTrace "sink" (ppr l) $
-    blockJoin first final_middle last : sink sunk' bs
-    where
-      l = entryLabel b
-      (first, middle, last) = blockSplit b
-      (middle', assigs) = walk (blockToList middle) emptyBlock
-                               (mapFindWithDefault [] l sunk)
-
-      (dropped_last, assigs') = partition (`conflictsWithLast` last) assigs
-
-      final_middle = foldl blockSnoc middle' (toNodes dropped_last)
-
-      sunk' = mapUnion sunk $
-                 mapFromList [ (l, filt assigs' (getLive l))
-                             | l <- successors last ]
-           where
-               getLive l = mapFindWithDefault Set.empty l liveness
-               filt as live = [ (r,e) | (r,e) <- as, r `Set.member` live ]
-
-
-walk :: [CmmNode O O] -> Block CmmNode O O -> [(LocalReg, CmmExpr)]
-     -> (Block CmmNode O O, [(LocalReg, CmmExpr)])
-
-walk []     acc as = (acc, as)
-walk (n:ns) acc as
-  | Just a <- collect_it  = walk ns acc (a:as)
-  | otherwise             = walk ns (foldr (flip blockSnoc) acc (n:drop_nodes)) as'
-  where
-    collect_it = case n of
-                   CmmAssign (CmmLocal r) e@(CmmReg (CmmGlobal _)) -> Just (r,e)
---                   CmmAssign (CmmLocal r) e@(CmmLoad addr _) |
---                      foldRegsUsed (\b r -> False) True addr -> Just (r,e)
-                   _ -> Nothing
-
-    drop_nodes = toNodes dropped
-    (dropped, as') = partition should_drop as
-       where should_drop a = a `conflicts` n
-
-toNodes :: [(LocalReg,CmmExpr)] -> [CmmNode O O]
-toNodes as = [ CmmAssign (CmmLocal r) rhs | (r,rhs) <- as ]
-
--- We only sink "r = G" assignments right now, so conflicts is very simple:
-conflicts :: (LocalReg,CmmExpr) -> CmmNode O O -> Bool
-(_, rhs) `conflicts` CmmAssign reg  _  | reg `regUsedIn` rhs = True
---(r, CmmLoad _ _) `conflicts` CmmStore _ _ = True
-(r, _)   `conflicts` node
-  = foldRegsUsed (\b r' -> r == r' || b) False node
-
-conflictsWithLast :: (LocalReg,CmmExpr) -> CmmNode O C -> Bool
-(r, _) `conflictsWithLast` node
-  = foldRegsUsed (\b r' -> r == r' || b) False node
diff --git a/compiler/cmm/CmmPipeline.hs b/compiler/cmm/CmmPipeline.hs
index bb8d5b2f22..f2a2855d7b 100644
--- a/compiler/cmm/CmmPipeline.hs
+++ b/compiler/cmm/CmmPipeline.hs
@@ -9,7 +9,6 @@ module CmmPipeline (
   cmmPipeline
 ) where
 
-import CLabel
 import Cmm
 import CmmLint
 import CmmBuildInfoTables
@@ -17,76 +16,42 @@ import CmmCommonBlockElim
 import CmmProcPoint
 import CmmContFlowOpt
 import CmmLayoutStack
+import CmmSink
+import Hoopl
 
 import UniqSupply
 import DynFlags
 import ErrUtils
 import HscTypes
-import Data.Maybe
 import Control.Monad
 import Outputable
 
-import qualified Data.Set as Set
-import Data.Map (Map)
-
 -----------------------------------------------------------------------------
 -- | Top level driver for C-- pipeline
 -----------------------------------------------------------------------------
--- There are two complications here:
--- 1. We need to compile the procedures in two stages because we need
---    an analysis of the procedures to tell us what CAFs they use.
---    The first stage returns a map from procedure labels to CAFs,
---    along with a closure that will compute SRTs and attach them to
---    the compiled procedures.
---    The second stage is to combine the CAF information into a top-level
---    CAF environment mapping non-static closures to the CAFs they keep live,
---    then pass that environment to the closures returned in the first
---    stage of compilation.
--- 2. We need to thread the module's SRT around when the SRT tables
---    are computed for each procedure.
---    The SRT needs to be threaded because it is grown lazily.
--- 3. We run control flow optimizations twice, once before any pipeline
---    work is done, and once again at the very end on all of the
---    resulting C-- blocks.  EZY: It's unclear whether or not whether
---    we actually need to do the initial pass.
+
 cmmPipeline  :: HscEnv -- Compilation env including
                        -- dynamic flags: -dcmm-lint -ddump-cps-cmm
              -> TopSRT     -- SRT table and accumulating list of compiled procs
              -> CmmGroup             -- Input C-- with Procedures
              -> IO (TopSRT, CmmGroup) -- Output CPS transformed C--
+
 cmmPipeline hsc_env topSRT prog =
   do let dflags = hsc_dflags hsc_env
-     --
-     showPass dflags "CPSZ"
-
-     (cafEnvs, tops) <- {-# SCC "tops" #-} liftM unzip $ mapM (cpsTop hsc_env) prog
-     -- tops :: [[(CmmDecl,CAFSet]]  (one list per group)
 
-     let topCAFEnv = {-# SCC "topCAFEnv" #-} mkTopCAFInfo (concat cafEnvs)
-
-     -- folding over the groups
-     (topSRT, tops) <- {-# SCC "toTops" #-} foldM (toTops topCAFEnv) (topSRT, []) tops
+     showPass dflags "CPSZ"
 
-     let cmms :: CmmGroup
-         cmms = reverse (concat tops)
+     tops <- {-# SCC "tops" #-} mapM (cpsTop hsc_env) prog
 
+     (topSRT, cmms) <- {-# SCC "toTops" #-} doSRTs topSRT tops
      dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "Post CPS Cmm" (ppr cmms)
 
      return (topSRT, cmms)
 
-{- [Note global fuel]
-~~~~~~~~~~~~~~~~~~~~~
-The identity and the last pass are stored in
-mutable reference cells in an 'HscEnv' and are
-global to one compiler session.
--}
 
--- EZY: It might be helpful to have an easy way of dumping the "pre"
--- input for any given phase, besides just turning it all on with
--- -ddump-cmmz
 
-cpsTop :: HscEnv -> CmmDecl -> IO ([(CLabel, CAFSet)], [(CAFSet, CmmDecl)])
-cpsTop _ p@(CmmData {}) = return ([], [(Set.empty, p)])
+cpsTop :: HscEnv -> CmmDecl -> IO (CAFEnv, [CmmDecl])
+cpsTop _ p@(CmmData {}) = return (mapEmpty, [p])
 cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}}) l g) =
     do
        ----------- Control-flow optimisations ---------------
@@ -110,8 +75,13 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}})
                          runUniqSM $ cmmLayoutStack procPoints entry_off g
        dump Opt_D_dump_cmmz_sp "Layout Stack" g
 
---       g <- {-# SCC "sink" #-} runUniqSM $ cmmSink g
---       dump Opt_D_dump_cmmz_rewrite "Sink assignments" g
+       g <- if optLevel dflags >= 99
+               then do g <- {-# SCC "sink" #-} return (cmmSink g)
+                       dump Opt_D_dump_cmmz_rewrite "Sink assignments" g
+                       g <- {-# SCC "inline" #-} return (cmmPeepholeInline g)
+                       dump Opt_D_dump_cmmz_rewrite "Peephole inline" g
+                       return g
+               else return g
 
 --       ----------- Sink and inline assignments -------------------
 --       g <- {-# SCC "rewriteAssignments" #-} runOptimization $
@@ -126,31 +96,21 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}})
              splitAtProcPoints l callPPs procPoints procPointMap (CmmProc h l g)
        dumps Opt_D_dump_cmmz_split "Post splitting" gs
 
-       ------------- More CAFs ------------------------------
+       ------------- CAF analysis ------------------------------
        let cafEnv = {-# SCC "cafAnal" #-} cafAnal g
-       let localCAFs = {-# SCC "localCAFs" #-} catMaybes $ map (localCAFInfo cafEnv) gs
-       mbpprTrace "localCAFs" (ppr localCAFs) $ return ()
 
-       -- NO MORE GRAPH TRANSFORMATION AFTER HERE -- JUST MAKING INFOTABLES
+       ------------- Populate info tables with stack info ------
        gs <- {-# SCC "setInfoTableStackMap" #-}
              return $ map (setInfoTableStackMap stackmaps) gs
        dumps Opt_D_dump_cmmz_info "after setInfoTableStackMap" gs
 
-       ----------- Control-flow optimisations ---------------
+       ----------- Control-flow optimisations -----------------
        gs <- {-# SCC "cmmCfgOpts(2)" #-} return $ map cmmCfgOptsProc gs
        dumps Opt_D_dump_cmmz_cfg "Post control-flow optimsations" gs
 
-       gs <- {-# SCC "bundleCAFs" #-} return $ map (bundleCAFs cafEnv) gs
-       dumps Opt_D_dump_cmmz_cafs "after bundleCAFs" gs
-
-       return (localCAFs, gs)
-
-              -- gs        :: [ (CAFSet, CmmDecl) ]
-              -- localCAFs :: [ (CLabel, CAFSet) ] -- statics filtered out(?)
+       return (cafEnv, gs)
 
   where dflags = hsc_dflags hsc_env
-        mbpprTrace x y z | dopt Opt_D_dump_cmmz dflags = pprTrace x y z
-                         | otherwise = z
         dump = dumpGraph dflags
 
         dumps flag name
@@ -182,14 +142,3 @@ dumpWith dflags flag txt g = do
    when (not (dopt flag dflags)) $
       dumpIfSet_dyn dflags Opt_D_dump_cmmz txt (ppr g)
 
--- This probably belongs in CmmBuildInfoTables?
--- We're just finishing the job here: once we know what CAFs are defined
--- in non-static closures, we can build the SRTs.
-toTops :: Map CLabel CAFSet -> (TopSRT, [[CmmDecl]])
-       -> [(CAFSet, CmmDecl)] -> IO (TopSRT, [[CmmDecl]])
-toTops topCAFEnv (topSRT, tops) gs =
-  do let setSRT (topSRT, rst) g =
-           do (topSRT, gs) <- setInfoTableSRT topCAFEnv topSRT g
-              return (topSRT, gs : rst)
-     (topSRT, gs') <- runUniqSM $ foldM setSRT (topSRT, []) gs
-     return (topSRT, concat gs' : tops)
diff --git a/compiler/cmm/CmmSink.hs b/compiler/cmm/CmmSink.hs
new file mode 100644
index 0000000000..fde34dc253
--- /dev/null
+++ b/compiler/cmm/CmmSink.hs
@@ -0,0 +1,256 @@
+{-# LANGUAGE GADTs #-}
+module CmmSink (
+     cmmSink,
+     cmmPeepholeInline
+  ) where
+
+import Cmm
+import BlockId
+import CmmLive
+import CmmUtils
+import Hoopl
+
+import UniqFM
+import Unique
+import Outputable
+
+import qualified Data.Set as Set
+
+-- -----------------------------------------------------------------------------
+-- Sinking
+
+-- This is an optimisation pass that
+--  (a) moves assignments closer to their uses, to reduce register pressure
+--  (b) pushes assignments into a single branch of a conditional if possible
+
+-- It is particularly helpful in the Cmm generated by the Stg->Cmm
+-- code generator, in which every function starts with a copyIn
+-- sequence like:
+--
+--    x1 = R1
+--    x2 = Sp[8]
+--    x3 = Sp[16]
+--    if (Sp - 32 < SpLim) then L1 else L2
+--
+-- we really want to push the x1..x3 assignments into the L2 branch.
+--
+-- Algorithm:
+--
+--  * Start by doing liveness analysis.
+--  * Keep a list of assignments; earlier ones may refer to later ones
+--  * Walk forwards through the graph;
+--    * At an assignment:
+--      * pick up the assignment and add it to the list
+--    * At a store:
+--      * drop any assignments that the store refers to
+--      * drop any assignments that refer to memory that may be written
+--        by the store
+--      * do this recursively, dropping dependent assignments
+--    * At a multi-way branch:
+--      * drop any assignments that are live on more than one branch
+--      * if any successor has more than one predecessor, drop everything
+--        live in that successor
+-- 
+-- As a side-effect we'll delete some dead assignments (transitively,
+-- even).  Maybe we could do without removeDeadAssignments?
+
+-- If we do this *before* stack layout, we might be able to avoid
+-- saving some things across calls/procpoints.
+--
+-- *but*, that will invalidate the liveness analysis, and we'll have
+-- to re-do it.
+
+cmmSink :: CmmGraph -> CmmGraph
+cmmSink graph = cmmSink' (cmmLiveness graph) graph
+
+type Assignment = (LocalReg, CmmExpr, AbsAddr)
+
+cmmSink' :: BlockEnv CmmLive -> CmmGraph -> CmmGraph
+cmmSink' liveness graph
+  = ofBlockList (g_entry graph) $ sink mapEmpty $ postorderDfs graph
+  where
+
+  sink :: BlockEnv [Assignment] -> [CmmBlock] -> [CmmBlock]
+  sink _ [] = []
+  sink sunk (b:bs) =
+    pprTrace "sink" (ppr lbl) $
+    blockJoin first final_middle last : sink sunk' bs
+    where
+      lbl = entryLabel b
+      (first, middle, last) = blockSplit b
+      (middle', assigs) = walk (blockToList middle) emptyBlock
+                               (mapFindWithDefault [] lbl sunk)
+
+      getLive l = mapFindWithDefault Set.empty l liveness
+      lives = map getLive (successors last)
+
+      -- multilive is a list of registers that are live in more than
+      -- one successor branch, and we should therefore drop them here.
+      multilive = [ r | (r,n) <- ufmToList livemap, n > 1 ]
+         where livemap = foldr (\r m -> addToUFM_C (+) m r (1::Int))
+                            emptyUFM (concatMap Set.toList lives)
+
+      (dropped_last, assigs') = dropAssignments drop_if assigs
+
+      drop_if a@(r,_,_) = a `conflicts` last || getUnique r `elem` multilive
+
+      final_middle = foldl blockSnoc middle' dropped_last
+
+      sunk' = mapUnion sunk $
+                 mapFromList [ (l, filterAssignments (getLive l) assigs')
+                             | l <- successors last ]
+
+
+filterAssignments :: RegSet -> [Assignment] -> [Assignment]
+filterAssignments live assigs = reverse (go assigs [])
+  where go []           kept = kept
+        go (a@(r,_,_):as) kept | needed    = go as (a:kept)
+                               | otherwise = go as kept
+           where
+              needed = r `Set.member` live || any (a `conflicts`) (map toNode kept)
+
+
+walk :: [CmmNode O O] -> Block CmmNode O O -> [Assignment]
+     -> (Block CmmNode O O, [Assignment])
+
+walk []     block as = (block, as)
+walk (n:ns) block as
+  | Just a <- shouldSink n = walk ns block (a : as)
+  | otherwise              = walk ns block' as'
+  where
+    (dropped, as') = dropAssignments (`conflicts` n) as
+    block' = foldl blockSnoc block dropped `blockSnoc` n
+
+shouldSink :: CmmNode O O -> Maybe Assignment
+shouldSink (CmmAssign (CmmLocal r) e) | no_local_regs = Just (r, e, exprAddr e)
+  where no_local_regs = foldRegsUsed (\_ _ -> False) True e
+shouldSink _other = Nothing
+
+toNode :: Assignment -> CmmNode O O
+toNode (r,rhs,_) = CmmAssign (CmmLocal r) rhs
+
+dropAssignments :: (Assignment -> Bool) -> [Assignment] -> ([CmmNode O O], [Assignment])
+dropAssignments should_drop assigs
+ = (dropped, reverse kept)
+ where
+   (dropped,kept) = go assigs [] []
+
+   go []             dropped kept = (dropped, kept)
+   go (assig : rest) dropped kept
+      | conflict  = go rest (toNode assig : dropped) kept
+      | otherwise = go rest dropped (assig:kept)
+      where
+        conflict = should_drop assig || any (assig `conflicts`) dropped
+
+-- | @conflicts (r,e) stmt@ is @False@ if and only if the assignment
+-- @r = e@ can be safely commuted past @stmt@.
+--
+-- We only sink "r = G" assignments right now, so conflicts is very simple:
+--
+conflicts :: Assignment -> CmmNode O x -> Bool
+(_, rhs, _   ) `conflicts` CmmAssign reg  _ | reg `regUsedIn` rhs = True
+(_, _,   addr) `conflicts` CmmStore addr' _ | addrConflicts addr (loadAddr addr') = True
+(r, _,   _)    `conflicts` node
+  = foldRegsUsed (\b r' -> r == r' || b) False node
+
+-- An abstraction of the addresses read or written.
+data AbsAddr = NoAddr | HeapAddr | StackAddr | AnyAddr
+
+bothAddrs :: AbsAddr -> AbsAddr -> AbsAddr
+bothAddrs NoAddr    x         = x
+bothAddrs x         NoAddr    = x
+bothAddrs HeapAddr  HeapAddr  = HeapAddr
+bothAddrs StackAddr StackAddr = StackAddr
+bothAddrs _         _         = AnyAddr
+
+addrConflicts :: AbsAddr -> AbsAddr -> Bool
+addrConflicts NoAddr    _         = False
+addrConflicts _         NoAddr    = False
+addrConflicts HeapAddr  StackAddr = False
+addrConflicts StackAddr HeapAddr  = False
+addrConflicts _         _         = True
+
+exprAddr :: CmmExpr -> AbsAddr -- here NoAddr means "no reads"
+exprAddr (CmmLoad addr _)  = loadAddr addr
+exprAddr (CmmMachOp _ es)  = foldr bothAddrs NoAddr (map exprAddr es)
+exprAddr _                 = NoAddr
+
+absAddr :: CmmExpr -> AbsAddr -- here NoAddr means "don't know"
+absAddr (CmmLoad addr _)  = bothAddrs HeapAddr (loadAddr addr) -- (1)
+absAddr (CmmMachOp _ es)  = foldr bothAddrs NoAddr (map absAddr es)
+absAddr (CmmReg r)        = regAddr r
+absAddr (CmmRegOff r _)   = regAddr r
+absAddr _ = NoAddr
+
+loadAddr :: CmmExpr -> AbsAddr
+loadAddr e = case absAddr e of
+               NoAddr -> HeapAddr -- (2)
+               a      -> a
+
+-- (1) we assume that an address read from memory is a heap address.
+-- We never read a stack address from memory.
+--
+-- (2) loading from an unknown address is assumed to be a heap load.
+
+regAddr :: CmmReg -> AbsAddr
+regAddr (CmmGlobal Sp) = StackAddr
+regAddr (CmmGlobal Hp) = HeapAddr
+regAddr _              = NoAddr
+
+-- After sinking, if we have an assignment to a temporary that is used
+-- exactly once, then it will either be of the form
+--
+--   x = E
+--   .. stmt involving x ..
+--
+-- OR
+--
+--   x = E
+--   .. stmt conflicting with E ..
+
+-- So the idea in peepholeInline is to spot the first case
+-- (recursively) and inline x.  We start with the set of live
+-- registers and move backwards through the block.
+--
+-- ToDo: doesn't inline into the last node
+--
+cmmPeepholeInline :: CmmGraph -> CmmGraph
+cmmPeepholeInline graph = ofBlockList (g_entry graph) $ map do_block (toBlockList graph)
+  where
+   liveness = cmmLiveness graph
+
+   do_block :: Block CmmNode C C -> Block CmmNode C C
+   do_block block = blockJoin first (go rmiddle live_middle) last
+     where
+       (first, middle, last) = blockSplit block
+       rmiddle = reverse (blockToList middle)
+    
+       live = Set.unions [ mapFindWithDefault Set.empty l liveness | l <- successors last ]
+    
+       live_middle = gen_kill last live
+    
+       go :: [CmmNode O O] -> RegSet -> Block CmmNode O O
+       go [] _ = emptyBlock
+       go [stmt] _ = blockCons stmt emptyBlock
+       go (stmt : rest) live = tryInline stmt usages live rest
+         where
+           usages :: UniqFM Int
+           usages = foldRegsUsed addUsage emptyUFM stmt
+    
+       addUsage :: UniqFM Int -> LocalReg -> UniqFM Int
+       addUsage m r = addToUFM_C (+) m r 1
+    
+       tryInline stmt usages live (CmmAssign (CmmLocal l) rhs : rest)
+          | not (l `elemRegSet` live),
+            Just 1 <- lookupUFM usages l = tryInline stmt' usages' live' rest
+          where live'   = foldRegsUsed extendRegSet live rhs
+                usages' = foldRegsUsed addUsage usages rhs
+    
+                stmt' = mapExpDeep inline stmt
+                   where inline (CmmReg    (CmmLocal l'))     | l == l' = rhs
+                         inline (CmmRegOff (CmmLocal l') off) | l == l' = cmmOffset rhs off
+                         inline other = other
+    
+       tryInline stmt _usages live stmts
+            = go stmts (gen_kill stmt live) `blockSnoc` stmt
+
diff --git a/compiler/cmm/PprCmm.hs b/compiler/cmm/PprCmm.hs
index 31c1794887..132f291540 100644
--- a/compiler/cmm/PprCmm.hs
+++ b/compiler/cmm/PprCmm.hs
@@ -231,13 +231,18 @@ pprNode node = pp_node <+> pp_debug
       CmmCall tgt k regs out res updfr_off ->
           hcat [ ptext (sLit "call"), space
                , pprFun tgt, parens (interpp'SP regs), space
-               , ptext (sLit "returns to") <+> ppr k <+> parens (ppr out)
-                                                     <+> parens (ppr res)
-               , ptext (sLit " with update frame") <+> ppr updfr_off
+               , returns <+>
+                 ptext (sLit "args: ") <> ppr out <> comma <+>
+                 ptext (sLit "res: ") <> ppr res <> comma <+>
+                 ptext (sLit "upd: ") <> ppr updfr_off
                , semi ]
           where pprFun f@(CmmLit _) = ppr f
                 pprFun f = parens (ppr f)
 
+                returns
+                  | Just r <- k = ptext (sLit "returns to") <+> ppr r <> comma
+                  | otherwise   = empty
+
       CmmForeignCall {tgt=t, res=rs, args=as, succ=s, updfr=u, intrbl=i} ->
           hcat $ if i then [ptext (sLit "interruptible"), space] else [] ++
                [ ptext (sLit "foreign call"), space
@@ -245,7 +250,7 @@ pprNode node = pp_node <+> pp_debug
                , ptext (sLit "returns to") <+> ppr s
                     <+> ptext (sLit "args:") <+> parens (ppr as)
                     <+> ptext (sLit "ress:") <+> parens (ppr rs)
-               , ptext (sLit " with update frame") <+> ppr u
+               , ptext (sLit "upd:") <+> ppr u
                , semi ]
 
     pp_debug :: SDoc
diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs
index 2a4486eb69..ff3cfc5189 100644
--- a/compiler/deSugar/Coverage.lhs
+++ b/compiler/deSugar/Coverage.lhs
@@ -423,6 +423,7 @@ isGoodBreakExpr (HsApp {})     = True
 isGoodBreakExpr (OpApp {})     = True
 isGoodBreakExpr (NegApp {})    = True
 isGoodBreakExpr (HsIf {})      = True
+isGoodBreakExpr (HsMultiIf {}) = True
 isGoodBreakExpr (HsCase {})    = True
 isGoodBreakExpr (RecordCon {}) = True
 isGoodBreakExpr (RecordUpd {}) = True
@@ -458,6 +459,8 @@ addTickHsExpr e@(HsOverLit _) = return e
 addTickHsExpr e@(HsLit _) = return e
 addTickHsExpr (HsLam matchgroup) =
         liftM HsLam (addTickMatchGroup True matchgroup)
+addTickHsExpr (HsLamCase ty mgs) =
+        liftM (HsLamCase ty) (addTickMatchGroup True mgs)
 addTickHsExpr (HsApp e1 e2) =
         liftM2 HsApp (addTickLHsExprNever e1) (addTickLHsExpr e2)
 addTickHsExpr (OpApp e1 e2 fix e3) =
@@ -494,6 +497,10 @@ addTickHsExpr (HsIf cnd e1 e2 e3) =
                 (addBinTickLHsExpr (BinBox CondBinBox) e1)
                 (addTickLHsExprOptAlt True e2)
                 (addTickLHsExprOptAlt True e3)
+addTickHsExpr (HsMultiIf ty alts)
+  = do { let isOneOfMany = case alts of [_] -> False; _ -> True
+       ; alts' <- mapM (liftL $ addTickGRHS isOneOfMany False) alts
+       ; return $ HsMultiIf ty alts' }
 addTickHsExpr (HsLet binds e) =
         bindLocals (collectLocalBinders binds) $
         liftM2 HsLet
diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs
index 11fa5d53c9..8c53c1aea1 100644
--- a/compiler/deSugar/DsExpr.lhs
+++ b/compiler/deSugar/DsExpr.lhs
@@ -205,6 +205,15 @@ dsExpr (NegApp expr neg_expr)
 dsExpr (HsLam a_Match)
   = uncurry mkLams <$> matchWrapper LambdaExpr a_Match
 
+dsExpr (HsLamCase arg matches@(MatchGroup _ rhs_ty))
+  | isEmptyMatchGroup matches   -- A Core 'case' is always non-empty
+  =                             -- So desugar empty HsLamCase to error call
+    mkErrorAppDs pAT_ERROR_ID (funResultTy rhs_ty) (ptext (sLit "\\case"))
+  | otherwise
+  = do { arg_var <- newSysLocalDs arg
+       ; ([discrim_var], matching_code) <- matchWrapper CaseAlt matches
+       ; return $ Lam arg_var $ bindNonRec discrim_var (Var arg_var) matching_code }
+
 dsExpr (HsApp fun arg)
   = mkCoreAppDs <$> dsLExpr fun <*>  dsLExpr arg
 \end{code}
@@ -328,6 +337,19 @@ dsExpr (HsIf mb_fun guard_expr then_expr else_expr)
            Just fun -> do { core_fun <- dsExpr fun
                           ; return (mkCoreApps core_fun [pred,b1,b2]) }
            Nothing  -> return $ mkIfThenElse pred b1 b2 }
+
+dsExpr (HsMultiIf res_ty alts)
+  | null alts
+  = mkErrorExpr
+
+  | otherwise
+  = do { match_result <- liftM (foldr1 combineMatchResults)
+                               (mapM (dsGRHS IfAlt res_ty) alts)
+       ; error_expr   <- mkErrorExpr
+       ; extractMatchResult match_result error_expr }
+  where
+    mkErrorExpr = mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID res_ty
+                               (ptext (sLit "multi-way if"))
 \end{code}
 
 
diff --git a/compiler/deSugar/DsGRHSs.lhs b/compiler/deSugar/DsGRHSs.lhs
index ed87d186af..9e84e46e9f 100644
--- a/compiler/deSugar/DsGRHSs.lhs
+++ b/compiler/deSugar/DsGRHSs.lhs
@@ -6,7 +6,7 @@
 Matching guarded right-hand-sides (GRHSs)
 
 \begin{code}
-module DsGRHSs ( dsGuarded, dsGRHSs ) where
+module DsGRHSs ( dsGuarded, dsGRHSs, dsGRHS ) where
 
 #include "HsVersions.h"
 
@@ -55,8 +55,8 @@ dsGRHSs :: HsMatchContext Name -> [Pat Id]      -- These are to build a MatchCon
         -> GRHSs Id                             -- Guarded RHSs
         -> Type                                 -- Type of RHS
         -> DsM MatchResult
-dsGRHSs hs_ctx pats (GRHSs grhss binds) rhs_ty = do
-    match_results <- mapM (dsGRHS hs_ctx pats rhs_ty) grhss
+dsGRHSs hs_ctx _ (GRHSs grhss binds) rhs_ty = do
+    match_results <- mapM (dsGRHS hs_ctx rhs_ty) grhss
     let
         match_result1 = foldr1 combineMatchResults match_results
         match_result2 = adjustMatchResultDs
@@ -66,8 +66,8 @@ dsGRHSs hs_ctx pats (GRHSs grhss binds) rhs_ty = do
     --
     return match_result2
 
-dsGRHS :: HsMatchContext Name -> [Pat Id] -> Type -> LGRHS Id -> DsM MatchResult
-dsGRHS hs_ctx _ rhs_ty (L _ (GRHS guards rhs))
+dsGRHS :: HsMatchContext Name -> Type -> LGRHS Id -> DsM MatchResult
+dsGRHS hs_ctx rhs_ty (L _ (GRHS guards rhs))
   = matchGuards (map unLoc guards) (PatGuard hs_ctx) rhs rhs_ty
 \end{code}
 
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index 9a1d050fb2..4d07c8c34e 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -864,6 +864,9 @@ repE e@(HsIPVar _) = notHandled "Implicit parameters" (ppr e)
 repE (HsOverLit l) = do { a <- repOverloadedLiteral l; repLit a }
 repE (HsLit l)     = do { a <- repLiteral l;           repLit a }
 repE (HsLam (MatchGroup [m] _)) = repLambda m
+repE (HsLamCase _ (MatchGroup ms _))
+                   = do { ms' <- mapM repMatchTup ms
+                        ; repLamCase (nonEmptyCoreList ms') }
 repE (HsApp x y)   = do {a <- repLE x; b <- repLE y; repApp a b}
 
 repE (OpApp e1 op _ e2) =
@@ -878,14 +881,19 @@ repE (NegApp x _)        = do
 repE (HsPar x)            = repLE x
 repE (SectionL x y)       = do { a <- repLE x; b <- repLE y; repSectionL a b }
 repE (SectionR x y)       = do { a <- repLE x; b <- repLE y; repSectionR a b }
-repE (HsCase e (MatchGroup ms _)) = do { arg <- repLE e
-				       ; ms2 <- mapM repMatchTup ms
-				       ; repCaseE arg (nonEmptyCoreList ms2) }
+repE (HsCase e (MatchGroup ms _))
+                          = do { arg <- repLE e
+                               ; ms2 <- mapM repMatchTup ms
+                               ; repCaseE arg (nonEmptyCoreList ms2) }
 repE (HsIf _ x y z)         = do
 			      a <- repLE x
 			      b <- repLE y
 			      c <- repLE z
 			      repCond a b c
+repE (HsMultiIf _ alts)
+  = do { (binds, alts') <- liftM unzip $ mapM repLGRHS alts
+       ; expr' <- repMultiIf (nonEmptyCoreList alts')
+       ; wrapGenSyms (concat binds) expr' }
 repE (HsLet bs e)         = do { (ss,ds) <- repBinds bs
 			       ; e2 <- addBinds ss (repLE e)
 			       ; z <- repLetE ds e2
@@ -976,22 +984,22 @@ repClauseTup (L _ (Match ps _ (GRHSs guards wheres))) =
 
 repGuards ::  [LGRHS Name] ->  DsM (Core TH.BodyQ)
 repGuards [L _ (GRHS [] e)]
-  = do {a <- repLE e; repNormal a }
-repGuards other
-  = do { zs <- mapM process other;
-     let {(xs, ys) = unzip zs};
-	 gd <- repGuarded (nonEmptyCoreList ys);
-     wrapGenSyms (concat xs) gd }
-  where
-    process :: LGRHS Name -> DsM ([GenSymBind], (Core (TH.Q (TH.Guard, TH.Exp))))
-    process (L _ (GRHS [L _ (ExprStmt e1 _ _ _)] e2))
-           = do { x <- repLNormalGE e1 e2;
-                  return ([], x) }
-    process (L _ (GRHS ss rhs))
-           = do (gs, ss') <- repLSts ss
-		rhs' <- addBinds gs $ repLE rhs
-                g <- repPatGE (nonEmptyCoreList ss') rhs'
-                return (gs, g)
+  = do { a <- repLE e
+       ; repNormal a }
+repGuards alts
+  = do { (binds, alts') <- liftM unzip $ mapM repLGRHS alts
+       ; body <- repGuarded (nonEmptyCoreList alts')
+       ; wrapGenSyms (concat binds) body }
+
+repLGRHS :: LGRHS Name -> DsM ([GenSymBind], (Core (TH.Q (TH.Guard, TH.Exp))))
+repLGRHS (L _ (GRHS [L _ (ExprStmt guard _ _ _)] rhs))
+  = do { guarded <- repLNormalGE guard rhs
+       ; return ([], guarded) }
+repLGRHS (L _ (GRHS stmts rhs))
+  = do { (gs, stmts') <- repLSts stmts
+       ; rhs'         <- addBinds gs $ repLE rhs
+       ; guarded      <- repPatGE (nonEmptyCoreList stmts') rhs'
+       ; return (gs, guarded) }
 
 repFields :: HsRecordBinds Name -> DsM (Core [TH.Q TH.FieldExp])
 repFields (HsRecFields { rec_flds = flds })
@@ -1455,6 +1463,9 @@ repApp (MkC x) (MkC y) = rep2 appEName [x,y]
 repLam :: Core [TH.PatQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
 repLam (MkC ps) (MkC e) = rep2 lamEName [ps, e]
 
+repLamCase :: Core [TH.MatchQ] -> DsM (Core TH.ExpQ)
+repLamCase (MkC ms) = rep2 lamCaseEName [ms]
+
 repTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
 repTup (MkC es) = rep2 tupEName [es]
 
@@ -1464,6 +1475,9 @@ repUnboxedTup (MkC es) = rep2 unboxedTupEName [es]
 repCond :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
 repCond (MkC x) (MkC y) (MkC z) = rep2 condEName [x,y,z]
 
+repMultiIf :: Core [TH.Q (TH.Guard, TH.Exp)] -> DsM (Core TH.ExpQ)
+repMultiIf (MkC alts) = rep2 multiIfEName [alts]
+
 repLetE :: Core [TH.DecQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
 repLetE (MkC ds) (MkC e) = rep2 letEName [ds, e]
 
@@ -1893,9 +1907,9 @@ templateHaskellNames = [
     clauseName,
     -- Exp
     varEName, conEName, litEName, appEName, infixEName,
-    infixAppName, sectionLName, sectionRName, lamEName,
+    infixAppName, sectionLName, sectionRName, lamEName, lamCaseEName,
     tupEName, unboxedTupEName,
-    condEName, letEName, caseEName, doEName, compEName,
+    condEName, multiIfEName, letEName, caseEName, doEName, compEName,
     fromEName, fromThenEName, fromToEName, fromThenToEName,
     listEName, sigEName, recConEName, recUpdEName,
     -- FieldExp
@@ -2058,8 +2072,9 @@ clauseName = libFun (fsLit "clause") clauseIdKey
 
 -- data Exp = ...
 varEName, conEName, litEName, appEName, infixEName, infixAppName,
-    sectionLName, sectionRName, lamEName, tupEName, unboxedTupEName, condEName,
-    letEName, caseEName, doEName, compEName :: Name
+    sectionLName, sectionRName, lamEName, lamCaseEName, tupEName,
+    unboxedTupEName, condEName, multiIfEName, letEName, caseEName,
+    doEName, compEName :: Name
 varEName        = libFun (fsLit "varE")        varEIdKey
 conEName        = libFun (fsLit "conE")        conEIdKey
 litEName        = libFun (fsLit "litE")        litEIdKey
@@ -2069,9 +2084,11 @@ infixAppName    = libFun (fsLit "infixApp")    infixAppIdKey
 sectionLName    = libFun (fsLit "sectionL")    sectionLIdKey
 sectionRName    = libFun (fsLit "sectionR")    sectionRIdKey
 lamEName        = libFun (fsLit "lamE")        lamEIdKey
+lamCaseEName    = libFun (fsLit "lamCaseE")    lamCaseEIdKey
 tupEName        = libFun (fsLit "tupE")        tupEIdKey
 unboxedTupEName = libFun (fsLit "unboxedTupE") unboxedTupEIdKey
 condEName       = libFun (fsLit "condE")       condEIdKey
+multiIfEName    = libFun (fsLit "multiIfE")    multiIfEIdKey
 letEName        = libFun (fsLit "letE")        letEIdKey
 caseEName       = libFun (fsLit "caseE")       caseEIdKey
 doEName         = libFun (fsLit "doE")         doEIdKey
@@ -2370,8 +2387,8 @@ clauseIdKey         = mkPreludeMiscIdUnique 262
 
 -- data Exp = ...
 varEIdKey, conEIdKey, litEIdKey, appEIdKey, infixEIdKey, infixAppIdKey,
-    sectionLIdKey, sectionRIdKey, lamEIdKey, tupEIdKey, unboxedTupEIdKey,
-    condEIdKey,
+    sectionLIdKey, sectionRIdKey, lamEIdKey, lamCaseEIdKey, tupEIdKey,
+    unboxedTupEIdKey, condEIdKey, multiIfEIdKey,
     letEIdKey, caseEIdKey, doEIdKey, compEIdKey,
     fromEIdKey, fromThenEIdKey, fromToEIdKey, fromThenToEIdKey,
     listEIdKey, sigEIdKey, recConEIdKey, recUpdEIdKey :: Unique
@@ -2384,21 +2401,23 @@ infixAppIdKey     = mkPreludeMiscIdUnique 275
 sectionLIdKey     = mkPreludeMiscIdUnique 276
 sectionRIdKey     = mkPreludeMiscIdUnique 277
 lamEIdKey         = mkPreludeMiscIdUnique 278
-tupEIdKey         = mkPreludeMiscIdUnique 279
-unboxedTupEIdKey  = mkPreludeMiscIdUnique 280
-condEIdKey        = mkPreludeMiscIdUnique 281
-letEIdKey         = mkPreludeMiscIdUnique 282
-caseEIdKey        = mkPreludeMiscIdUnique 283
-doEIdKey          = mkPreludeMiscIdUnique 284
-compEIdKey        = mkPreludeMiscIdUnique 285
-fromEIdKey        = mkPreludeMiscIdUnique 286
-fromThenEIdKey    = mkPreludeMiscIdUnique 287
-fromToEIdKey      = mkPreludeMiscIdUnique 288
-fromThenToEIdKey  = mkPreludeMiscIdUnique 289
-listEIdKey        = mkPreludeMiscIdUnique 290
-sigEIdKey         = mkPreludeMiscIdUnique 291
-recConEIdKey      = mkPreludeMiscIdUnique 292
-recUpdEIdKey      = mkPreludeMiscIdUnique 293
+lamCaseEIdKey     = mkPreludeMiscIdUnique 279
+tupEIdKey         = mkPreludeMiscIdUnique 280
+unboxedTupEIdKey  = mkPreludeMiscIdUnique 281
+condEIdKey        = mkPreludeMiscIdUnique 282
+multiIfEIdKey     = mkPreludeMiscIdUnique 283
+letEIdKey         = mkPreludeMiscIdUnique 284
+caseEIdKey        = mkPreludeMiscIdUnique 285
+doEIdKey          = mkPreludeMiscIdUnique 286
+compEIdKey        = mkPreludeMiscIdUnique 287
+fromEIdKey        = mkPreludeMiscIdUnique 288
+fromThenEIdKey    = mkPreludeMiscIdUnique 289
+fromToEIdKey      = mkPreludeMiscIdUnique 290
+fromThenToEIdKey  = mkPreludeMiscIdUnique 291
+listEIdKey        = mkPreludeMiscIdUnique 292
+sigEIdKey         = mkPreludeMiscIdUnique 293
+recConEIdKey      = mkPreludeMiscIdUnique 294
+recUpdEIdKey      = mkPreludeMiscIdUnique 295
 
 -- type FieldExp = ...
 fieldExpIdKey :: Unique
diff --git a/compiler/deSugar/Match.lhs b/compiler/deSugar/Match.lhs
index c80446a751..8fd3a203f3 100644
--- a/compiler/deSugar/Match.lhs
+++ b/compiler/deSugar/Match.lhs
@@ -88,6 +88,7 @@ matchCheck_really dflags ctx@(DsMatchContext hs_ctx _) vars ty qs
     incomplete_flag :: HsMatchContext id -> Bool
     incomplete_flag (FunRhs {})   = wopt Opt_WarnIncompletePatterns dflags
     incomplete_flag CaseAlt       = wopt Opt_WarnIncompletePatterns dflags
+    incomplete_flag IfAlt         = False
 
     incomplete_flag LambdaExpr    = wopt Opt_WarnIncompleteUniPatterns dflags
     incomplete_flag PatBindRhs    = wopt Opt_WarnIncompleteUniPatterns dflags
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index 04735ed1b9..13e58d13e4 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -186,6 +186,7 @@ Library
         CmmParse
         CmmProcPoint
         CmmRewriteAssignments
+        CmmSink
         CmmType
         CmmUtils
         CmmLayoutStack
diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs
index 3ad5aa03fa..abcdb3ed40 100644
--- a/compiler/hsSyn/Convert.lhs
+++ b/compiler/hsSyn/Convert.lhs
@@ -482,6 +482,12 @@ cvtl e = wrapL (cvt e)
     cvt (AppE x y)     = do { x' <- cvtl x; y' <- cvtl y; return $ HsApp x' y' }
     cvt (LamE ps e)    = do { ps' <- cvtPats ps; e' <- cvtl e
 			    ; return $ HsLam (mkMatchGroup [mkSimpleMatch ps' e']) }
+    cvt (LamCaseE ms)
+      | null ms        = failWith (ptext (sLit "Lambda-case expression with no alternatives"))
+      | otherwise      = do { ms' <- mapM cvtMatch ms
+                            ; return $ HsLamCase placeHolderType
+                                                 (mkMatchGroup ms')
+                            }
     cvt (TupE [e])     = do { e' <- cvtl e; return $ HsPar e' }
     	      	       	         -- Note [Dropping constructors]
                                  -- Singleton tuples treated like nothing (just parens)
@@ -489,6 +495,10 @@ cvtl e = wrapL (cvt e)
     cvt (UnboxedTupE es)      = do { es' <- mapM cvtl es; return $ ExplicitTuple (map Present es') Unboxed }
     cvt (CondE x y z)  = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z;
 			    ; return $ HsIf (Just noSyntaxExpr) x' y' z' }
+    cvt (MultiIfE alts)
+      | null alts      = failWith (ptext (sLit "Multi-way if-expression with no alternatives"))
+      | otherwise      = do { alts' <- mapM cvtpair alts
+                            ; return $ HsMultiIf placeHolderType alts' }
     cvt (LetE ds e)    = do { ds' <- cvtLocalDecs (ptext (sLit "a let expression")) ds
                             ; e' <- cvtl e; return $ HsLet ds' e' }
     cvt (CaseE e ms)
diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs
index 390898000d..bac9ec6348 100644
--- a/compiler/hsSyn/HsDecls.lhs
+++ b/compiler/hsSyn/HsDecls.lhs
@@ -435,7 +435,7 @@ data TyClDecl name
 
   | -- | @type/data declaration
     TyDecl { tcdLName  :: Located name            -- ^ Type constructor
-           , tcdTyVars :: LHsTyVarBndrs name      -- ^ Type variables; for an assoicated type
+           , tcdTyVars :: LHsTyVarBndrs name      -- ^ Type variables; for an associated type
                                                   --   these include outer binders
                                                   -- Eg  class T a where
                                                   --       type F a :: *
diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs
index dcfcb9f8f0..12a5fad800 100644
--- a/compiler/hsSyn/HsExpr.lhs
+++ b/compiler/hsSyn/HsExpr.lhs
@@ -113,6 +113,8 @@ data HsExpr id
 
   | HsLam     (MatchGroup id)           -- Currently always a single match
 
+  | HsLamCase PostTcType (MatchGroup id) -- Lambda-case
+
   | HsApp     (LHsExpr id) (LHsExpr id) -- Application
 
   -- Operator applications:
@@ -150,6 +152,8 @@ data HsExpr id
                 (LHsExpr id)    --  then part
                 (LHsExpr id)    --  else part
 
+  | HsMultiIf   PostTcType [LGRHS id] -- Multi-way if
+
   | HsLet       (HsLocalBinds id) -- let(rec)
                 (LHsExpr  id)
 
@@ -448,6 +452,10 @@ ppr_expr (ExplicitTuple exprs boxity)
 ppr_expr (HsLam matches)
   = pprMatches (LambdaExpr :: HsMatchContext id) matches
 
+ppr_expr (HsLamCase _ matches)
+  = sep [ sep [ptext (sLit "\\case {")],
+          nest 2 (pprMatches (CaseAlt :: HsMatchContext id) matches <+> char '}') ]
+
 ppr_expr (HsCase expr matches)
   = sep [ sep [ptext (sLit "case"), nest 4 (ppr expr), ptext (sLit "of {")],
           nest 2 (pprMatches (CaseAlt :: HsMatchContext id) matches <+> char '}') ]
@@ -458,6 +466,12 @@ ppr_expr (HsIf _ e1 e2 e3)
          ptext (sLit "else"),
          nest 4 (ppr e3)]
 
+ppr_expr (HsMultiIf _ alts)
+  = sep $ ptext (sLit "if") : map ppr_alt alts
+  where ppr_alt (L _ (GRHS guards expr)) =
+          sep [ char '|' <+> interpp'SP guards
+              , ptext (sLit "->") <+> pprDeeper (ppr expr) ]
+
 -- special case: let ... in let ...
 ppr_expr (HsLet binds expr@(L _ (HsLet _ _)))
   = sep [hang (ptext (sLit "let")) 2 (hsep [pprBinds binds, ptext (sLit "in")]),
@@ -1107,7 +1121,7 @@ pprStmt (TransStmt { trS_stmts = stmts, trS_by = by, trS_using = using, trS_form
 pprStmt (RecStmt { recS_stmts = segment, recS_rec_ids = rec_ids
                  , recS_later_ids = later_ids })
   = ptext (sLit "rec") <+> 
-    vcat [ braces (vcat (map ppr segment))
+    vcat [ ppr_do_stmts segment
          , ifPprDebug (vcat [ ptext (sLit "rec_ids=") <> ppr rec_ids
                             , ptext (sLit "later_ids=") <> ppr later_ids])]
 
@@ -1139,7 +1153,7 @@ pprDo PArrComp    stmts = paBrackets $ pprComp stmts
 pprDo MonadComp   stmts = brackets    $ pprComp stmts
 pprDo _           _     = panic "pprDo" -- PatGuard, ParStmtCxt
 
-ppr_do_stmts :: OutputableBndr id => [LStmt id] -> SDoc
+ppr_do_stmts :: (OutputableBndr idL, OutputableBndr idR) => [LStmtLR idL idR] -> SDoc
 -- Print a bunch of do stmts, with explicit braces and semicolons,
 -- so that we are not vulnerable to layout bugs
 ppr_do_stmts stmts 
@@ -1257,6 +1271,7 @@ data HsMatchContext id  -- Context of a Match
   = FunRhs id Bool              -- Function binding for f; True <=> written infix
   | LambdaExpr                  -- Patterns of a lambda
   | CaseAlt                     -- Patterns and guards on a case alternative
+  | IfAlt                       -- Guards of a multi-way if alternative
   | ProcExpr                    -- Patterns of a proc
   | PatBindRhs                  -- A pattern binding  eg [y] <- e = e
 
@@ -1307,6 +1322,7 @@ isMonadCompExpr _                    = False
 matchSeparator :: HsMatchContext id -> SDoc
 matchSeparator (FunRhs {})  = ptext (sLit "=")
 matchSeparator CaseAlt      = ptext (sLit "->")
+matchSeparator IfAlt        = ptext (sLit "->")
 matchSeparator LambdaExpr   = ptext (sLit "->")
 matchSeparator ProcExpr     = ptext (sLit "->")
 matchSeparator PatBindRhs   = ptext (sLit "=")
@@ -1329,6 +1345,7 @@ pprMatchContextNoun :: Outputable id => HsMatchContext id -> SDoc
 pprMatchContextNoun (FunRhs fun _)  = ptext (sLit "equation for")
                                       <+> quotes (ppr fun)
 pprMatchContextNoun CaseAlt         = ptext (sLit "case alternative")
+pprMatchContextNoun IfAlt           = ptext (sLit "multi-way if alternative")
 pprMatchContextNoun RecUpd          = ptext (sLit "record-update construct")
 pprMatchContextNoun ThPatQuote      = ptext (sLit "Template Haskell pattern quotation")
 pprMatchContextNoun PatBindRhs      = ptext (sLit "pattern binding")
@@ -1377,6 +1394,7 @@ pprStmtContext (TransStmtCtxt c)
 matchContextErrString :: Outputable id => HsMatchContext id -> SDoc
 matchContextErrString (FunRhs fun _)             = ptext (sLit "function") <+> ppr fun
 matchContextErrString CaseAlt                    = ptext (sLit "case")
+matchContextErrString IfAlt                      = ptext (sLit "multi-way if")
 matchContextErrString PatBindRhs                 = ptext (sLit "pattern binding")
 matchContextErrString RecUpd                     = ptext (sLit "record update")
 matchContextErrString LambdaExpr                 = ptext (sLit "lambda")
diff --git a/compiler/iface/IfaceType.lhs b/compiler/iface/IfaceType.lhs
index c484b0637f..225a3c812b 100644
--- a/compiler/iface/IfaceType.lhs
+++ b/compiler/iface/IfaceType.lhs
@@ -37,11 +37,13 @@ module IfaceType (
 
 import Coercion
 import TypeRep hiding( maybeParen )
+import Unique( hasKey )
 import TyCon
 import Id
 import Var
 import TysWiredIn
 import TysPrim
+import PrelNames( funTyConKey )
 import Name
 import BasicTypes
 import Outputable
@@ -352,7 +354,10 @@ toIfaceContext = toIfaceTypes
 ----------------
 coToIfaceType :: Coercion -> IfaceType
 coToIfaceType (Refl ty)             = IfaceCoConApp IfaceReflCo [toIfaceType ty]
-coToIfaceType (TyConAppCo tc cos)   = IfaceTyConApp (toIfaceTyCon tc) 
+coToIfaceType (TyConAppCo tc cos)   
+  | tc `hasKey` funTyConKey
+  , [arg,res] <- cos                = IfaceFunTy (coToIfaceType arg) (coToIfaceType res)
+  | otherwise                       = IfaceTyConApp (toIfaceTyCon tc) 
                                                     (map coToIfaceType cos)
 coToIfaceType (AppCo co1 co2)       = IfaceAppTy    (coToIfaceType co1) 
                                                     (coToIfaceType co2)
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 690b77ea4a..314efb95f1 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -486,6 +486,8 @@ data ExtensionFlag
    | Opt_NondecreasingIndentation
    | Opt_RelaxedLayout
    | Opt_TraditionalRecordSyntax
+   | Opt_LambdaCase
+   | Opt_MultiWayIf
    deriving (Eq, Enum, Show)
 
 -- | Contains not only a collection of 'DynFlag's but also a plethora of
@@ -1016,7 +1018,7 @@ defaultLogAction :: LogAction
 defaultLogAction dflags severity srcSpan style msg
     = case severity of
       SevOutput -> printSDoc msg style
-      SevDump   -> hPrintDump dflags stdout msg
+      SevDump   -> printSDoc (msg $$ blankLine) style
       SevInfo   -> printErrs msg style
       SevFatal  -> printErrs msg style
       _         -> do hPutChar stderr '\n'
@@ -2165,6 +2167,8 @@ xFlags = [
   ( "NondecreasingIndentation",         Opt_NondecreasingIndentation, nop ),
   ( "RelaxedLayout",                    Opt_RelaxedLayout, nop ),
   ( "TraditionalRecordSyntax",          Opt_TraditionalRecordSyntax, nop ),
+  ( "LambdaCase",                       Opt_LambdaCase, nop ),
+  ( "MultiWayIf",                       Opt_MultiWayIf, nop ),
   ( "MonoLocalBinds",                   Opt_MonoLocalBinds, nop ),
   ( "RelaxedPolyRec",                   Opt_RelaxedPolyRec,
     \ turn_on -> if not turn_on
diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.lhs
index daa66f9d2f..1643128eb7 100644
--- a/compiler/main/ErrUtils.lhs
+++ b/compiler/main/ErrUtils.lhs
@@ -230,6 +230,9 @@ mkDumpDoc hdr doc
 -- | Write out a dump.
 --      If --dump-to-file is set then this goes to a file.
 --      otherwise emit to stdout.
+-- 
+-- When hdr is empty, we print in a more compact format (no separators and
+-- blank lines)
 dumpSDoc :: DynFlags -> DynFlag -> String -> SDoc -> IO ()
 dumpSDoc dflags dflag hdr doc
  = do let mFile = chooseDumpFile dflags dflag
@@ -247,12 +250,18 @@ dumpSDoc dflags dflag hdr doc
                             writeIORef gdref (Set.insert fileName gd)
                         createDirectoryIfMissing True (takeDirectory fileName)
                         handle <- openFile fileName mode
-                        hPrintDump dflags handle doc
+                        let doc'
+                              | null hdr  = doc
+                              | otherwise = doc $$ blankLine
+                        defaultLogActionHPrintDoc dflags handle doc' defaultDumpStyle
                         hClose handle
 
             -- write the dump to stdout
-            Nothing
-                 -> log_action dflags dflags SevDump noSrcSpan defaultDumpStyle (mkDumpDoc hdr doc)
+            Nothing -> do
+              let (doc', severity)
+                    | null hdr  = (doc, SevOutput)
+                    | otherwise = (mkDumpDoc hdr doc, SevDump)
+              log_action dflags dflags severity noSrcSpan defaultDumpStyle doc'
 
 
 -- | Choose where to put a dump file based on DynFlags
diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index df400f574a..cef5974fb0 100644
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -500,6 +500,7 @@ data Token
   | ITdcolon
   | ITequal
   | ITlam
+  | ITlcase
   | ITvbar
   | ITlarrow
   | ITrarrow
@@ -979,23 +980,37 @@ splitQualName orig_buf len parens = split orig_buf orig_buf
 
 varid :: Action
 varid span buf len =
-  fs `seq`
   case lookupUFM reservedWordsFM fs of
-        Just (keyword,0)    -> do
-                maybe_layout keyword
-                return (L span keyword)
-        Just (keyword,exts) -> do
-                b <- extension (\i -> exts .&. i /= 0)
-                if b then do maybe_layout keyword
-                             return (L span keyword)
-                     else return (L span (ITvarid fs))
-        _other -> return (L span (ITvarid fs))
+    Just (ITcase, _) -> do
+      lambdaCase <- extension lambdaCaseEnabled
+      keyword <- if lambdaCase
+                 then do
+                   lastTk <- getLastTk
+                   return $ case lastTk of
+                     Just ITlam -> ITlcase
+                     _          -> ITcase
+                 else
+                   return ITcase
+      maybe_layout keyword
+      return $ L span keyword
+    Just (keyword, 0) -> do
+      maybe_layout keyword
+      return $ L span keyword
+    Just (keyword, exts) -> do
+      extsEnabled <- extension $ \i -> exts .&. i /= 0
+      if extsEnabled
+        then do
+          maybe_layout keyword
+          return $ L span keyword
+        else
+          return $ L span $ ITvarid fs
+    Nothing ->
+      return $ L span $ ITvarid fs
   where
-        fs = lexemeToFastString buf len
+    !fs = lexemeToFastString buf len
 
 conid :: StringBuffer -> Int -> Token
-conid buf len = ITconid fs
-  where fs = lexemeToFastString buf len
+conid buf len = ITconid $! lexemeToFastString buf len
 
 qvarsym, qconsym, prefixqvarsym, prefixqconsym :: StringBuffer -> Int -> Token
 qvarsym buf len = ITqvarsym $! splitQualName buf len False
@@ -1007,17 +1022,18 @@ varsym, consym :: Action
 varsym = sym ITvarsym
 consym = sym ITconsym
 
-sym :: (FastString -> Token) -> RealSrcSpan -> StringBuffer -> Int
-    -> P (RealLocated Token)
+sym :: (FastString -> Token) -> Action
 sym con span buf len =
   case lookupUFM reservedSymsFM fs of
-        Just (keyword,exts) -> do
-                b <- extension exts
-                if b then return (L span keyword)
-                     else return (L span $! con fs)
-        _other -> return (L span $! con fs)
+    Just (keyword, exts) -> do
+      extsEnabled <- extension exts
+      let !tk | extsEnabled = keyword
+              | otherwise   = con fs
+      return $ L span tk
+    Nothing ->
+      return $ L span $! con fs
   where
-        fs = lexemeToFastString buf len
+    !fs = lexemeToFastString buf len
 
 -- Variations on the integral numeric literal.
 tok_integral :: (Integer -> Token)
@@ -1094,6 +1110,7 @@ maybe_layout t = do -- If the alternative layout rule is enabled then
     where f ITdo    = pushLexState layout_do
           f ITmdo   = pushLexState layout_do
           f ITof    = pushLexState layout
+          f ITlcase = pushLexState layout
           f ITlet   = pushLexState layout
           f ITwhere = pushLexState layout
           f ITrec   = pushLexState layout
@@ -1520,6 +1537,7 @@ data PState = PState {
         buffer     :: StringBuffer,
         dflags     :: DynFlags,
         messages   :: Messages,
+        last_tk    :: Maybe Token,
         last_loc   :: RealSrcSpan, -- pos of previous token
         last_len   :: !Int,        -- len of previous token
         loc        :: RealSrcLoc,  -- current loc (end of prev token + 1)
@@ -1624,6 +1642,12 @@ setLastToken loc len = P $ \s -> POk s {
   last_len=len
   } ()
 
+setLastTk :: Token -> P ()
+setLastTk tk = P $ \s -> POk s { last_tk = Just tk } ()
+
+getLastTk :: P (Maybe Token)
+getLastTk = P $ \s@(PState { last_tk = last_tk }) -> POk s last_tk
+
 data AlexInput = AI RealSrcLoc StringBuffer
 
 alexInputPrevChar :: AlexInput -> Char
@@ -1839,6 +1863,10 @@ typeLiteralsBit :: Int
 typeLiteralsBit = 28
 explicitNamespacesBit :: Int
 explicitNamespacesBit = 29
+lambdaCaseBit :: Int
+lambdaCaseBit = 30
+multiWayIfBit :: Int
+multiWayIfBit = 31
 
 
 always :: Int -> Bool
@@ -1888,6 +1916,10 @@ typeLiteralsEnabled flags = testBit flags typeLiteralsBit
 
 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
 --
@@ -1904,6 +1936,7 @@ mkPState flags buf loc =
       buffer        = buf,
       dflags        = flags,
       messages      = emptyMessages,
+      last_tk       = Nothing,
       last_loc      = mkRealSrcSpan loc loc,
       last_len      = 0,
       loc           = loc,
@@ -1947,6 +1980,8 @@ mkPState flags buf loc =
                .|. traditionalRecordSyntaxBit  `setBitIf` xopt Opt_TraditionalRecordSyntax  flags
                .|. 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
@@ -2274,7 +2309,13 @@ lexToken = do
         let span = mkRealSrcSpan loc1 end
         let bytes = byteDiff buf buf2
         span `seq` setLastToken span bytes
-        t span buf bytes
+        lt <- t span buf bytes
+        case unLoc lt of
+          ITlineComment _  -> return lt
+          ITblockComment _ -> return lt
+          lt' -> do
+            setLastTk lt'
+            return lt
 
 reportLexError :: RealSrcLoc -> RealSrcLoc -> StringBuffer -> [Char] -> P a
 reportLexError loc1 loc2 buf str
diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index 21f8782f6f..62132277d9 100644
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -55,7 +55,7 @@ import FastString
 import Maybes           ( orElse )
 import Outputable
 
-import Control.Monad    ( unless )
+import Control.Monad    ( unless, liftM )
 import GHC.Exts
 import Data.Char
 import Control.Monad    ( mplus )
@@ -275,6 +275,7 @@ incorrect.
  '::'           { L _ ITdcolon }
  '='            { L _ ITequal }
  '\\'           { L _ ITlam }
+ 'lcase'        { L _ ITlcase }
  '|'            { L _ ITvbar }
  '<-'           { L _ ITlarrow }
  '->'           { L _ ITrarrow }
@@ -1388,9 +1389,13 @@ exp10 :: { LHsExpr RdrName }
                                                                 (unguardedGRHSs $6)
                                                             ]) }
         | 'let' binds 'in' exp                  { LL $ HsLet (unLoc $2) $4 }
+        | '\\' 'lcase' altslist
+            { LL $ HsLamCase placeHolderType (mkMatchGroup (unLoc $3)) }
         | 'if' exp optSemi 'then' exp optSemi 'else' exp
                                         {% checkDoAndIfThenElse $2 $3 $5 $6 $8 >>
                                            return (LL $ mkHsIf $2 $5 $8) }
+        | 'if' gdpats                   {% hintMultiWayIf (getLoc $1) >>
+                                           return (LL $ HsMultiIf placeHolderType (reverse $ unLoc $2)) }
         | 'case' exp 'of' altslist              { LL $ HsCase $2 (mkMatchGroup (unLoc $4)) }
         | '-' fexp                              { LL $ NegApp $2 noSyntaxExpr }
 
@@ -2138,4 +2143,11 @@ fileSrcSpan = do
   l <- getSrcLoc; 
   let loc = mkSrcLoc (srcLocFile l) 1 1;
   return (mkSrcSpan loc loc)
+
+-- Hint about the MultiWayIf extension
+hintMultiWayIf :: SrcSpan -> P ()
+hintMultiWayIf span = do
+  mwiEnabled <- liftM ((Opt_MultiWayIf `xopt`) . dflags) getPState
+  unless mwiEnabled $ parseErrorSDoc span $
+    text "Multi-way if-expressions need -XMultiWayIf turned on"
 }
diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs
index d3d16033eb..2c70698fdd 100644
--- a/compiler/rename/RnBinds.lhs
+++ b/compiler/rename/RnBinds.lhs
@@ -25,7 +25,7 @@ module RnBinds (
 
    -- Other bindings
    rnMethodBinds, renameSigs, mkSigTvFn,
-   rnMatchGroup, rnGRHSs,
+   rnMatchGroup, rnGRHSs, rnGRHS,
    makeMiniFixityEnv, MiniFixityEnv,
    HsSigCtxt(..)
    ) where
diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs
index 1868be9269..78a64344f3 100644
--- a/compiler/rename/RnExpr.lhs
+++ b/compiler/rename/RnExpr.lhs
@@ -29,7 +29,7 @@ import {-# SOURCE #-} TcSplice( runQuasiQuoteExpr )
 
 import RnSource  ( rnSrcDecls, findSplice )
 import RnBinds   ( rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS,
-                   rnMatchGroup, makeMiniFixityEnv) 
+                   rnMatchGroup, rnGRHS, makeMiniFixityEnv) 
 import HsSyn
 import TcRnMonad
 import TcEnv		( thRnBrack )
@@ -224,6 +224,10 @@ rnExpr (HsLam matches)
   = rnMatchGroup LambdaExpr matches	`thenM` \ (matches', fvMatch) ->
     return (HsLam matches', fvMatch)
 
+rnExpr (HsLamCase arg matches)
+  = rnMatchGroup CaseAlt matches	`thenM` \ (matches', fvs_ms) ->
+    return (HsLamCase arg matches', fvs_ms)
+
 rnExpr (HsCase expr matches)
   = rnLExpr expr		 	`thenM` \ (new_expr, e_fvs) ->
     rnMatchGroup CaseAlt matches	`thenM` \ (new_matches, ms_fvs) ->
@@ -280,6 +284,10 @@ rnExpr (HsIf _ p b1 b2)
        ; (mb_ite, fvITE) <- lookupIfThenElse
        ; return (HsIf mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) }
 
+rnExpr (HsMultiIf ty alts)
+  = do { (alts', fvs) <- mapFvRn (rnGRHS IfAlt) alts
+       ; return (HsMultiIf ty alts', fvs) }
+
 rnExpr (HsType a)
   = rnLHsType HsTypeCtx a	`thenM` \ (t, fvT) -> 
     return (HsType t, fvT)
diff --git a/compiler/simplCore/SimplCore.lhs b/compiler/simplCore/SimplCore.lhs
index d8c6732c34..731f55128c 100644
--- a/compiler/simplCore/SimplCore.lhs
+++ b/compiler/simplCore/SimplCore.lhs
@@ -586,7 +586,7 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode)
         -- about to begin, with '1' for the first
       | iteration_no > max_iterations   -- Stop if we've run out of iterations
       = WARN( debugIsOn && (max_iterations > 2)
-            , hang (ptext (sLit "Simplifier baling out after") <+> int max_iterations
+            , hang (ptext (sLit "Simplifier bailing out after") <+> int max_iterations
                     <+> ptext (sLit "iterations")
                     <+> (brackets $ hsep $ punctuate comma $
                          map (int . simplCountN) (reverse counts_so_far)))
diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs
index df9013cd08..f2ed224df4 100644
--- a/compiler/simplCore/Simplify.lhs
+++ b/compiler/simplCore/Simplify.lhs
@@ -1571,21 +1571,22 @@ tryRules env rules fn args call_cont
   where
     trace_dump dflags rule rule_rhs
       | dopt Opt_D_dump_rule_rewrites dflags
-      = liftIO . dumpSDoc dflags Opt_D_dump_rule_rewrites "" $
-           vcat [text "Rule fired",
-                 text "Rule:" <+> ftext (ru_name rule),
-                 text "Before:" <+> hang (ppr fn) 2 (sep (map pprParendExpr args)),
-                 text "After: " <+> pprCoreExpr rule_rhs,
-                 text "Cont:  " <+> ppr call_cont]
+      = log_rule dflags Opt_D_dump_rule_rewrites "Rule fired" $ vcat
+          [ text "Rule:" <+> ftext (ru_name rule)
+          , text "Before:" <+> hang (ppr fn) 2 (sep (map pprParendExpr args))
+          , text "After: " <+> pprCoreExpr rule_rhs
+          , text "Cont:  " <+> ppr call_cont ]
 
       | dopt Opt_D_dump_rule_firings dflags
-      = liftIO . dumpSDoc dflags Opt_D_dump_rule_firings "" $
-          vcat [text "Rule fired",
-                ftext (ru_name rule)]
+      = log_rule dflags Opt_D_dump_rule_firings "Rule fired:" $
+          ftext (ru_name rule)
 
       | otherwise
       = return ()
 
+    log_rule dflags dflag hdr details = liftIO . dumpSDoc dflags dflag "" $
+      sep [text hdr, nest 4 details]
+
 \end{code}
 
 Note [Rules for recursive functions]
diff --git a/compiler/specialise/Rules.lhs b/compiler/specialise/Rules.lhs
index 498302a5e9..0cf858e7b5 100644
--- a/compiler/specialise/Rules.lhs
+++ b/compiler/specialise/Rules.lhs
@@ -726,7 +726,7 @@ match_co :: RuleEnv
 match_co renv subst (CoVarCo cv) co
   = match_var renv subst cv (Coercion co)
 match_co _ _ co1 _
-  = pprTrace "match_co baling out" (ppr co1) Nothing
+  = pprTrace "match_co bailing out" (ppr co1) Nothing
 
 -------------
 rnMatchBndr2 :: RuleEnv -> RuleSubst -> Var -> Var -> RuleEnv
diff --git a/compiler/typecheck/TcCanonical.lhs b/compiler/typecheck/TcCanonical.lhs
index 284d0218f5..b013e258f3 100644
--- a/compiler/typecheck/TcCanonical.lhs
+++ b/compiler/typecheck/TcCanonical.lhs
@@ -364,30 +364,29 @@ newSCWorkFromFlavored d flavor cls xis
     
   | isGiven flavor 
   = do { let sc_theta = immSuperClasses cls xis 
-             xev = XEvTerm { ev_comp = panic "Can't compose for given!" 
-                           , ev_decomp = \x -> zipWith (\_ i -> EvSuperClass x i) sc_theta [0..] }
+             xev_decomp x = zipWith (\_ i -> EvSuperClass x i) sc_theta [0..] 
+             xev = XEvTerm { ev_comp   = panic "Can't compose for given!" 
+                           , ev_decomp = xev_decomp }
        ; ctevs <- xCtFlavor flavor sc_theta xev
-       ; emit_sc_flavs d ctevs }
+
+       ; traceTcS "newSCWork/Given" $ ppr "ctevs =" <+> ppr ctevs 
+       ; mapM_ emit_non_can ctevs }
 
   | isEmptyVarSet (tyVarsOfTypes xis)
-  = return () -- Wanteds/Derived with no variables yield no deriveds.
+  = return () -- Wanteds with no variables yield no deriveds.
               -- See Note [Improvement from Ground Wanteds]
 
-  | otherwise -- Wanted/Derived case, just add those SC that can lead to improvement. 
+  | otherwise -- Wanted case, just add those SC that can lead to improvement. 
   = do { let sc_rec_theta = transSuperClasses cls xis 
-             impr_theta   = filter is_improvement_pty sc_rec_theta              
-             xev = panic "Derived's are not supposed to transform evidence!" 
-             der_ev = Derived { ctev_wloc = ctev_wloc flavor, ctev_pred = ctev_pred flavor }
-       ; ctevs <- xCtFlavor der_ev impr_theta xev
-       ; emit_sc_flavs d ctevs }
-
-emit_sc_flavs :: SubGoalDepth -> [CtEvidence] -> TcS ()
-emit_sc_flavs d fls 
-  = do { traceTcS "newSCWorkFromFlavored" $
-         text "Emitting superclass work:" <+> ppr sc_cts
-       ; updWorkListTcS $ appendWorkListCt sc_cts }
-  where 
-    sc_cts = map (\fl -> CNonCanonical { cc_ev = fl, cc_depth  = d }) fls
+             impr_theta   = filter is_improvement_pty sc_rec_theta
+       ; traceTcS "newSCWork/Derived" $ text "impr_theta =" <+> ppr impr_theta
+       ; mapM_ emit_der impr_theta }
+
+  where emit_der pty = newDerived (ctev_wloc flavor) pty >>= mb_emit
+        mb_emit Nothing     = return ()
+        mb_emit (Just ctev) = emit_non_can ctev 
+        emit_non_can ctev   = updWorkListTcS $ 
+                              extendWorkListCt (CNonCanonical ctev d)
 
 is_improvement_pty :: PredType -> Bool 
 -- Either it's an equality, or has some functional dependency
@@ -507,7 +506,8 @@ flatten :: SubGoalDepth -- Depth
 flatten d f ctxt ty 
   | Just ty' <- tcView ty
   = do { (xi, co) <- flatten d f ctxt ty'
-       ; return (xi,co) } 
+       ; if eqType xi ty then return (ty,co) else return (xi,co) } 
+       -- Small tweak for better error messages 
 
 flatten _ _ _ xi@(LitTy {}) = return (xi, mkTcReflCo xi)
 
diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs
index 0a5d941adf..8d79e89d97 100644
--- a/compiler/typecheck/TcDeriv.lhs
+++ b/compiler/typecheck/TcDeriv.lhs
@@ -855,7 +855,7 @@ inferConstraints cls inst_tys rep_tc rep_tc_args
 
 Note [Getting base classes]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Functor and Typeable are define in package 'base', and that is not available
+Functor and Typeable are defined in package 'base', and that is not available
 when compiling 'ghc-prim'.  So we must be careful that 'deriving' for stuff in 
 ghc-prim does not use Functor or Typeable implicitly via these lookups.
 
diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs
index f3c238bd66..51b5eb3fa7 100644
--- a/compiler/typecheck/TcExpr.lhs
+++ b/compiler/typecheck/TcExpr.lhs
@@ -201,6 +201,14 @@ tcExpr (HsLam match) res_ty
   = do	{ (co_fn, match') <- tcMatchLambda match res_ty
 	; return (mkHsWrap co_fn (HsLam match')) }
 
+tcExpr e@(HsLamCase _ matches) res_ty
+  = do	{ (co_fn, [arg_ty], body_ty) <- matchExpectedFunTys msg 1 res_ty
+	; matches' <- tcMatchesCase match_ctxt arg_ty matches body_ty
+	; return $ mkHsWrapCo co_fn $ HsLamCase arg_ty matches' }
+  where msg = sep [ ptext (sLit "The function") <+> quotes (ppr e)
+                  , ptext (sLit "requires")]
+        match_ctxt = MC { mc_what = CaseAlt, mc_body = tcBody }
+
 tcExpr (ExprWithTySig expr sig_ty) res_ty
  = do { sig_tc_ty <- tcHsSigType ExprSigCtxt sig_ty
 
@@ -437,6 +445,11 @@ tcExpr (HsIf (Just fun) pred b1 b2) res_ty   -- Note [Rebindable syntax for if]
        -- and it maintains uniformity with other rebindable syntax
        ; return (HsIf (Just fun') pred' b1' b2') }
 
+tcExpr (HsMultiIf _ alts) res_ty
+  = do { alts' <- mapM (wrapLocM $ tcGRHS match_ctxt res_ty) alts
+       ; return $ HsMultiIf res_ty alts' }
+  where match_ctxt = MC { mc_what = IfAlt, mc_body = tcBody }
+
 tcExpr (HsDo do_or_lc stmts _) res_ty
   = tcDoStmts do_or_lc stmts res_ty
 
diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs
index aa444715b0..922b2cd404 100644
--- a/compiler/typecheck/TcHsSyn.lhs
+++ b/compiler/typecheck/TcHsSyn.lhs
@@ -557,6 +557,11 @@ zonkExpr env (HsLam matches)
   = zonkMatchGroup env matches	`thenM` \ new_matches ->
     returnM (HsLam new_matches)
 
+zonkExpr env (HsLamCase arg matches)
+  = zonkTcTypeToType env arg	`thenM` \ new_arg ->
+    zonkMatchGroup env matches	`thenM` \ new_matches ->
+    returnM (HsLamCase new_arg new_matches)
+
 zonkExpr env (HsApp e1 e2)
   = zonkLExpr env e1	`thenM` \ new_e1 ->
     zonkLExpr env e2	`thenM` \ new_e2 ->
@@ -616,6 +621,15 @@ zonkExpr env (HsIf e0 e1 e2 e3)
        ; new_e3 <- zonkLExpr env e3
        ; returnM (HsIf new_e0 new_e1 new_e2 new_e3) }
 
+zonkExpr env (HsMultiIf ty alts)
+  = do { alts' <- mapM (wrapLocM zonk_alt) alts
+       ; ty'   <- zonkTcTypeToType env ty
+       ; returnM $ HsMultiIf ty' alts' }
+  where zonk_alt (GRHS guard expr)
+          = do { (env', guard') <- zonkStmts env guard
+               ; expr'          <- zonkLExpr env' expr
+               ; returnM $ GRHS guard' expr' }
+
 zonkExpr env (HsLet binds expr)
   = zonkLocalBinds env binds	`thenM` \ (new_env, new_binds) ->
     zonkLExpr new_env expr	`thenM` \ new_expr ->
diff --git a/compiler/typecheck/TcMatches.lhs b/compiler/typecheck/TcMatches.lhs
index 2941a17092..acc20649c0 100644
--- a/compiler/typecheck/TcMatches.lhs
+++ b/compiler/typecheck/TcMatches.lhs
@@ -13,10 +13,10 @@ TcMatches: Typecheck some @Matches@
 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
 -- for details
 
-module TcMatches ( tcMatchesFun, tcGRHSsPat, tcMatchesCase, tcMatchLambda,
-		   TcMatchCtxt(..), TcStmtChecker,
-		   tcStmts, tcStmtsAndThen, tcDoStmts, tcBody,
-		   tcDoStmt, tcGuardStmt
+module TcMatches ( tcMatchesFun, tcGRHSsPat, tcGRHS, tcMatchesCase,
+                   tcMatchLambda, TcMatchCtxt(..), TcStmtChecker,
+                   tcStmts, tcStmtsAndThen, tcDoStmts, tcBody,
+                   tcDoStmt, tcGuardStmt
        ) where
 
 import {-# SOURCE #-}	TcExpr( tcSyntaxOp, tcInferRhoNC, tcInferRho, tcCheckId,
diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs
index f0c69c5819..4073e4e6f8 100644
--- a/compiler/typecheck/TcSMonad.lhs
+++ b/compiler/typecheck/TcSMonad.lhs
@@ -66,8 +66,8 @@ module TcSMonad (
     InertSet(..), InertCans(..), 
     getInertEqs, getCtCoercion,
     emptyInert, getTcSInerts, lookupInInerts, 
-    extractUnsolved,
-    extractUnsolvedTcS, modifyInertTcS,
+    getInertUnsolved, getInertInsols, splitInertsForImplications,
+    modifyInertTcS,
     updInertSetTcS, partitionCCanMap, partitionEqMap,
     getRelevantCts, extractRelevantInerts,
     CCanMap(..), CtTypeMap, CtFamHeadMap, CtPredMap,
@@ -362,6 +362,13 @@ extractUnsolvedCMap cmap =
   in (wntd `unionBags` derd, 
       cmap { cts_wanted = emptyUFM, cts_derived = emptyUFM })
 
+extractWantedCMap :: CCanMap a -> (Cts, CCanMap a)
+-- Gets the wanted /only/ constraints and returns a residual
+-- CCanMap with only givens or derived
+extractWantedCMap cmap =
+  let wntd = foldUFM unionBags emptyCts (cts_wanted cmap)
+  in (wntd, cmap { cts_wanted = emptyUFM })
+
 
 -- Maps from PredTypes to Constraints
 type CtTypeMap    = TypeMap    Ct
@@ -655,64 +662,92 @@ modifyInertTcS upd
        ; return a }
 
 
-extractUnsolvedTcS :: TcS (Cts,Cts) 
--- Extracts frozen errors and remaining unsolved and sets the 
--- inert set to be the remaining! 
-extractUnsolvedTcS = modifyInertTcS extractUnsolved 
-
-extractUnsolved :: InertSet -> ((Cts,Cts), InertSet)
--- Postcondition
--- -------------
--- When: 
---   ((frozen,cts),is_solved) <- extractUnsolved inert
--- Then: 
--- -----------------------------------------------------------------------------
---  cts       |  The unsolved (Derived or Wanted only) residual 
---            |  canonical constraints, that is, no CNonCanonicals.
--- -----------|-----------------------------------------------------------------
---  frozen    | The CNonCanonicals of the original inert (frozen errors), 
---            | of all flavors
--- -----------|-----------------------------------------------------------------
---  is_solved | Whatever remains from the inert after removing the previous two. 
--- -----------------------------------------------------------------------------
-extractUnsolved (IS { inert_cans = IC { inert_eqs    = eqs
-                                      , inert_eq_tvs = eq_tvs
-                                      , inert_irreds = irreds
-                                      , inert_funeqs = funeqs
-                                      , inert_dicts  = dicts
-                                      }
-                    , inert_frozen = frozen
-                    , inert_solved = solved
-                    , inert_flat_cache = flat_cache 
-                    , inert_solved_funeqs = funeq_cache
-                    })
-  
-  = let is_solved  = IS { inert_cans = IC { inert_eqs    = solved_eqs
-                                          , inert_eq_tvs = eq_tvs
-                                          , inert_dicts  = solved_dicts
-                                          , inert_irreds = solved_irreds
-                                          , inert_funeqs = solved_funeqs }
-                        , inert_frozen = emptyCts -- All out
-                                         
-                              -- At some point, I used to flush all the solved, in 
-                              -- fear of evidence loops. But I think we are safe, 
-                              -- flushing is why T3064 had become slower
-                        , inert_solved        = solved      -- PredMap emptyTM
-                        , inert_flat_cache    = flat_cache  -- FamHeadMap emptyTM
-                        , inert_solved_funeqs = funeq_cache -- FamHeadMap emptyTM
-                        }
-    in ((frozen, unsolved), is_solved)
-
-  where solved_eqs = filterVarEnv_Directly (\_ ct -> isGivenCt ct) eqs
-        unsolved_eqs = foldVarEnv (\ct cts -> cts `extendCts` ct) emptyCts $
-                       eqs `minusVarEnv` solved_eqs
-
-        (unsolved_irreds, solved_irreds) = Bag.partitionBag (not.isGivenCt) irreds
-        (unsolved_dicts, solved_dicts)   = extractUnsolvedCMap dicts
-        (unsolved_funeqs, solved_funeqs) = partCtFamHeadMap (not . isGivenCt) funeqs
-
-        unsolved = unsolved_eqs `unionBags` unsolved_irreds `unionBags`
-                   unsolved_dicts `unionBags` unsolved_funeqs
+
+splitInertsForImplications :: InertSet -> ([Ct],InertSet)
+-- Converts the Wanted of the original inert to Given and removes 
+-- all Wanted and Derived from the inerts.
+-- DV: Is the removal of Derived essential? 
+splitInertsForImplications is
+  = let (cts,is') = extractWanted is
+    in  (givens_from_unsolved cts,is')
+  where givens_from_unsolved = foldrBag get_unsolved []
+        get_unsolved cc rest_givens
+            | pushable_wanted cc
+            = let fl   = ctEvidence cc
+                  gfl  = Given { ctev_gloc = setCtLocOrigin (ctev_wloc fl) UnkSkol
+                               , ctev_evtm = EvId (ctev_evar fl)
+                               , ctev_pred = ctev_pred fl }
+                  this_given = cc { cc_ev = gfl }
+              in this_given : rest_givens
+            | otherwise = rest_givens 
+
+        pushable_wanted :: Ct -> Bool 
+        pushable_wanted cc 
+         = isEqPred (ctPred cc) -- see Note [Preparing inert set for implications]
+
+        -- Returns Wanted constraints and a Derived/Given InertSet
+        extractWanted (IS { inert_cans = IC { inert_eqs    = eqs
+                                            , inert_eq_tvs = eq_tvs
+                                            , inert_irreds = irreds
+                                            , inert_funeqs = funeqs
+                                            , inert_dicts  = dicts
+                                            }
+                          , inert_frozen = _frozen
+                          , inert_solved = solved
+                          , inert_flat_cache = flat_cache 
+                          , inert_solved_funeqs = funeq_cache
+                          })
+          
+          = let is_solved  = IS { inert_cans = IC { inert_eqs    = solved_eqs
+                                                  , inert_eq_tvs = eq_tvs
+                                                  , inert_dicts  = solved_dicts
+                                                  , inert_irreds = solved_irreds
+                                                  , inert_funeqs = solved_funeqs }
+                                , inert_frozen = emptyCts -- All out
+                                                 
+                                      -- At some point, I used to flush all the solved, in 
+                                      -- fear of evidence loops. But I think we are safe, 
+                                      -- flushing is why T3064 had become slower
+                                , inert_solved        = solved      -- PredMap emptyTM
+                                , inert_flat_cache    = flat_cache  -- FamHeadMap emptyTM
+                                , inert_solved_funeqs = funeq_cache -- FamHeadMap emptyTM
+                                }
+            in (wanted, is_solved)
+
+          where gd_eqs = filterVarEnv_Directly (\_ ct -> not (isWantedCt ct)) eqs
+                wanted_eqs = foldVarEnv (\ct cts -> cts `extendCts` ct) emptyCts $ 
+                             eqs `minusVarEnv` gd_eqs
+                
+                (wanted_irreds, gd_irreds) = Bag.partitionBag isWantedCt irreds
+                (wanted_dicts,  gd_dicts)  = extractWantedCMap dicts
+                (wanted_funeqs, gd_funeqs) = partCtFamHeadMap isWantedCt funeqs
+
+                -- Is this all necessary? 
+                solved_eqs        = filterVarEnv_Directly (\_ ct -> isGivenCt ct) gd_eqs 
+                solved_irreds     = Bag.filterBag isGivenCt gd_irreds
+                (_,solved_dicts)  = extractUnsolvedCMap gd_dicts
+                (_,solved_funeqs) = partCtFamHeadMap (not . isGivenCt) gd_funeqs
+
+                wanted = wanted_eqs `unionBags` wanted_irreds `unionBags`
+                         wanted_dicts `unionBags` wanted_funeqs
+
+
+getInertInsols :: InertSet -> Cts
+-- Insolubles only
+getInertInsols is = inert_frozen is
+
+getInertUnsolved :: InertSet -> Cts
+-- Unsolved Wanted or Derived only 
+getInertUnsolved (IS { inert_cans = icans }) 
+  = let unsolved_eqs = foldVarEnv add_if_not_given emptyCts (inert_eqs icans)
+        add_if_not_given ct cts
+            | isGivenCt ct = cts
+            | otherwise    = cts `extendCts` ct
+        (unsolved_irreds,_) = Bag.partitionBag (not . isGivenCt) (inert_irreds icans)
+        (unsolved_dicts,_)  = extractUnsolvedCMap (inert_dicts icans)
+        (unsolved_funeqs,_) = partCtFamHeadMap (not . isGivenCt) (inert_funeqs icans)
+    in unsolved_eqs `unionBags` unsolved_irreds `unionBags` 
+       unsolved_dicts `unionBags` unsolved_funeqs
 
 
 
diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs
index 4417408100..914d463f1f 100644
--- a/compiler/typecheck/TcSimplify.lhs
+++ b/compiler/typecheck/TcSimplify.lhs
@@ -65,7 +65,7 @@ simplifyTop wanteds
   = do { ev_binds_var <- newTcEvBinds
                          
        ; zonked_wanteds <- zonkWC wanteds
-       ; wc_first_go <- runTcSWithEvBinds ev_binds_var $ solveWanteds zonked_wanteds
+       ; wc_first_go <- solveWantedsWithEvBinds ev_binds_var zonked_wanteds
        ; cts <- applyTyVarDefaulting wc_first_go 
                 -- See Note [Top-level Defaulting Plan]
                 
@@ -79,7 +79,7 @@ simplifyTop wanteds
           = do { traceTc "simpl_top_loop }" empty
                ; TcRnMonad.getTcEvBinds ev_binds_var }
           | otherwise
-          = do { wc_residual <- runTcSWithEvBinds ev_binds_var $ solveWanteds wc
+          = do { wc_residual <- solveWantedsWithEvBinds ev_binds_var wc
                ; let wc_flat_approximate = approximateWC wc_residual
                ; (dflt_eqs,_unused_bind) <- runTcS $
                                             applyDefaultingRules wc_flat_approximate
@@ -198,13 +198,17 @@ simplifyDeriv orig pred tvs theta
        ; traceTc "simplifyDeriv" $ 
          vcat [ pprTvBndrs tvs $$ ppr theta $$ ppr wanted, doc ]
        ; (residual_wanted, _ev_binds1)
-             <- runTcS $ solveWanteds (mkFlatWC wanted)
+             <- solveWanteds (mkFlatWC wanted)
 
        ; let (good, bad) = partitionBagWith get_good (wc_flat residual_wanted)
                          -- See Note [Exotic derived instance contexts]
              get_good :: Ct -> Either PredType Ct
-             get_good ct | validDerivPred skol_set p = Left p
-                         | otherwise                 = Right ct
+             get_good ct | validDerivPred skol_set p 
+                         , isWantedCt ct  = Left p 
+                         -- NB: residual_wanted may contain unsolved
+                         -- Derived and we stick them into the bad set
+                         -- so that reportUnsolved may decide what to do with them
+                         | otherwise = Right ct
                          where p = ctPred ct
 
        -- We never want to defer these errors because they are errors in the
@@ -363,8 +367,7 @@ simplifyInfer _top_lvl apply_mr name_taus (untch,wanteds)
               -- bindings, so we can't just revert to the input
               -- constraint.
        ; ev_binds_var <- newTcEvBinds
-       ; wanted_transformed <- runTcSWithEvBinds ev_binds_var $ 
-                               solveWanteds zonked_wanteds
+       ; wanted_transformed <- solveWantedsWithEvBinds ev_binds_var zonked_wanteds
 
               -- Step 3) Fail fast if there is an insoluble constraint,
               -- unless we are deferring errors to runtime
@@ -376,12 +379,13 @@ simplifyInfer _top_lvl apply_mr name_taus (untch,wanteds)
               -- NB: Already the fixpoint of any unifications that may have happened                                
               -- NB: We do not do any defaulting when inferring a type, this can lead
               -- to less polymorphic types, see Note [Default while Inferring]
-                                
+              -- NB: quant_candidates here are wanted or derived, we filter the wanteds later, anyway
+ 
               -- Step 5) Minimize the quantification candidates                             
        ; (quant_candidates_transformed, _extra_binds)   
-             <- runTcS $ solveWanteds $ WC { wc_flat  = quant_candidates
-                                           , wc_impl  = emptyBag
-                                           , wc_insol = emptyBag }
+             <- solveWanteds $ WC { wc_flat  = quant_candidates
+                                  , wc_impl  = emptyBag
+                                  , wc_insol = emptyBag }
 
               -- Step 6) Final candidates for quantification                
        ; let final_quant_candidates :: Bag PredType
@@ -515,6 +519,7 @@ to check the original wanted.
 
 
 approximateWC :: WantedConstraints -> Cts
+-- Postcondition: Wanted or Derived Cts 
 approximateWC wc = float_wc emptyVarSet wc
   where 
     float_wc :: TcTyVarSet -> WantedConstraints -> Cts
@@ -529,7 +534,7 @@ approximateWC wc = float_wc emptyVarSet wc
     float_flat :: TcTyVarSet -> Ct -> Cts
     float_flat skols ct
       | tyVarsOfCt ct `disjointVarSet` skols 
-      , isWantedCt ct = singleCt ct
+      = singleCt ct
       | otherwise = emptyCts
         
     do_bag :: (a -> Bag c) -> Bag a -> Bag c
@@ -642,7 +647,7 @@ simplifyRule name lhs_wanted rhs_wanted
              
              	 -- We allow ourselves to unify environment 
 		 -- variables: runTcS runs with NoUntouchables
-       ; (resid_wanted, _) <- runTcS (solveWanteds zonked_all)
+       ; (resid_wanted, _) <- solveWanteds zonked_all
 
        ; zonked_lhs <- zonkWC lhs_wanted
 
@@ -696,7 +701,7 @@ simplifyCheck wanteds
        ; traceTc "simplifyCheck {" (vcat
              [ ptext (sLit "wanted =") <+> ppr wanteds ])
 
-       ; (unsolved, eb1) <- runTcS (solveWanteds wanteds)
+       ; (unsolved, eb1) <- solveWanteds wanteds
 
        ; traceTc "simplifyCheck }" $ ptext (sLit "unsolved =") <+> ppr unsolved
 
@@ -748,37 +753,28 @@ and does not fail if -fwarn-type-errors is on, so that we can continue
 compilation. The errors are turned into warnings in `reportUnsolved`.
 
 \begin{code}
-solveWanteds :: WantedConstraints -> TcS WantedConstraints
--- Returns: residual constraints, plus evidence bindings 
--- NB: When we are called from TcM there are no inerts to pass down to TcS
-solveWanteds wanted
-  = do { (_,wc_out) <- solve_wanteds wanted
-       ; let wc_ret = wc_out { wc_flat = keepWanted (wc_flat wc_out) } 
-                      -- Discard Derived
-       ; return wc_ret }
-
-solve_wanteds :: WantedConstraints
-              -> TcS (TvSubst, WantedConstraints) 
-              -- NB: wc_flats may be wanted *or* derived now
-              -- Returns the flattening substitution as well in case we need to apply it
+
+solveWanteds :: WantedConstraints -> TcM (WantedConstraints, Bag EvBind)
+-- Return the evidence binds in the BagEvBinds result
+solveWanteds wanted = runTcS $ solve_wanteds wanted 
+
+solveWantedsWithEvBinds :: EvBindsVar -> WantedConstraints -> TcM WantedConstraints
+-- Side-effect the EvBindsVar argument to add new bindings from solving
+solveWantedsWithEvBinds ev_binds_var wanted
+  = runTcSWithEvBinds ev_binds_var $ solve_wanteds wanted
+
+
+solve_wanteds :: WantedConstraints -> TcS WantedConstraints 
+-- NB: wc_flats may be wanted /or/ derived now
 solve_wanteds wanted@(WC { wc_flat = flats, wc_impl = implics, wc_insol = insols }) 
   = do { traceTcS "solveWanteds {" (ppr wanted)
 
-                 -- Try the flat bit
-                 -- Discard from insols all the derived/given constraints
-                 -- because they will show up again when we try to solve
-                 -- everything else.  Solving them a second time is a bit
-                 -- of a waste, but the code is simple, and the program is
-                 -- wrong anyway!
-
-                 -- DV: why only keepWanted? We make sure that we never float out
-                 -- whatever constraints can yield equalities, including class 
-                 -- constraints with functional dependencies and hence all the derived
-                 -- that were potentially insoluble will be re-generated.
-                 -- (It would not hurt though to just keep the wanted and the derived)
-                 -- See Note [The HasEqualities Predicate] in Inst.lhs
-         
+         -- Try the flat bit, including insolubles. Solving insolubles a 
+         -- second time round is a bit of a waste but the code is simple 
+         -- and the program is wrong anyway. 
+         -- Why keepWanted insols? See Note [KeepWanted in SolveWanteds] 
        ; let all_flats = flats `unionBags` keepWanted insols
+             -- DV: Used to be 'keepWanted insols' but just insols is
                          
        ; impls_from_flats <- solveInteractCts $ bagToList all_flats
 
@@ -786,7 +782,9 @@ solve_wanteds wanted@(WC { wc_flat = flats, wc_impl = implics, wc_insol = insols
        -- out of one or more of the implications. 
        ; unsolved_implics <- simpl_loop 1 (implics `unionBags` impls_from_flats)
 
-       ; (insoluble_flats,unsolved_flats) <- extractUnsolvedTcS 
+       ; is <- getTcSInerts 
+       ; let insoluble_flats = getInertInsols is
+             unsolved_flats  = getInertUnsolved is
 
        ; bb <- getTcEvBindsMap
        ; tb <- getTcSTyBindsMap
@@ -798,20 +796,17 @@ solve_wanteds wanted@(WC { wc_flat = flats, wc_impl = implics, wc_insol = insols
                       , text "current tybinds  =" <+> vcat (map ppr (varEnvElts tb))
                       ]
 
-       ; (subst, remaining_unsolved_flats) <- solveCTyFunEqs unsolved_flats
-                -- See Note [Solving Family Equations]
-                -- NB: remaining_flats has already had subst applied
+       ; let wc =  WC { wc_flat  = unsolved_flats
+                      , wc_impl  = unsolved_implics
+                      , wc_insol = insoluble_flats }
+
 
        ; traceTcS "solveWanteds finished with" $
-                 vcat [ text "remaining_unsolved_flats =" <+> ppr remaining_unsolved_flats
-                      , text "subst =" <+> ppr subst
-                      ]
+                 vcat [ text "wc (unflattened) =" <+> ppr wc ]
+
+       ; unFlattenWC wc }
+
 
-       ; return $ 
-         (subst, WC { wc_flat  = mapBag (substCt subst) remaining_unsolved_flats
-                    , wc_impl  = mapBag (substImplication subst) unsolved_implics
-                    , wc_insol = mapBag (substCt subst) insoluble_flats })
-       }
 
 simpl_loop :: Int
            -> Bag Implication
@@ -822,24 +817,24 @@ simpl_loop n implics
   | otherwise 
   = do { (implic_eqs, unsolved_implics) <- solveNestedImplications implics
 
-       ; inerts <- getTcSInerts
-       ; let ((_,unsolved_flats),_) = extractUnsolved inerts
-                                      
        ; let improve_eqs = implic_eqs
              -- NB: improve_eqs used to contain defaulting equations HERE but 
              -- defaulting now happens only at simplifyTop and not deep inside 
              -- simpl_loop! See Note [Top-level Defaulting Plan]
-             
+
+       ; unsolved_flats <- getTcSInerts >>= (return . getInertUnsolved) 
        ; traceTcS "solveWanteds: simpl_loop end" $
              vcat [ text "improve_eqs      =" <+> ppr improve_eqs
                   , text "unsolved_flats   =" <+> ppr unsolved_flats
                   , text "unsolved_implics =" <+> ppr unsolved_implics ]
 
+
        ; if isEmptyBag improve_eqs then return unsolved_implics 
          else do { impls_from_eqs <- solveInteractCts $ bagToList improve_eqs
                  ; simpl_loop (n+1) (unsolved_implics `unionBags` 
                                                  impls_from_eqs)} }
 
+
 solveNestedImplications :: Bag Implication
                         -> TcS (Cts, Bag Implication)
 -- Precondition: the TcS inerts may contain unsolved flats which have 
@@ -849,19 +844,17 @@ solveNestedImplications implics
   = return (emptyBag, emptyBag)
   | otherwise 
   = do { inerts <- getTcSInerts
-       ; traceTcS "solveNestedImplications starting, inerts are:" $ ppr inerts
-         
-       ; let ((_insoluble_flats, unsolved_flats),thinner_inerts) = extractUnsolved inerts 
+       ; traceTcS "solveNestedImplications starting, inerts are:" $ ppr inerts         
+       ; let (pushed_givens, thinner_inerts) = splitInertsForImplications inerts
+  
        ; traceTcS "solveNestedImplications starting, more info:" $ 
-         vcat [ text "inerts          = " <+> ppr inerts
-              , text "insoluble_flats = " <+> ppr _insoluble_flats
-              , text "unsolved_flats  = " <+> ppr unsolved_flats
+         vcat [ text "original inerts = " <+> ppr inerts
+              , text "pushed_givens   = " <+> ppr pushed_givens
               , text "thinner_inerts  = " <+> ppr thinner_inerts ]
          
        ; (implic_eqs, unsolved_implics)
            <- doWithInert thinner_inerts $ 
-              do { let pushed_givens = givens_from_wanteds unsolved_flats
-                       tcs_untouchables 
+              do { let tcs_untouchables 
                          = foldr (unionVarSet . tyVarsOfCt) emptyVarSet pushed_givens
                                           -- Typically pushed_givens is very small, consists
                                           -- only of unsolved equalities, so no inefficiency 
@@ -892,23 +885,6 @@ solveNestedImplications implics
 
        ; return (implic_eqs, unsolved_implics) }
 
-  where givens_from_wanteds = foldrBag get_wanted []
-        get_wanted cc rest_givens
-            | pushable_wanted cc
-            = let fl   = ctEvidence cc
-                  gfl  = Given { ctev_gloc = setCtLocOrigin (ctev_wloc fl) UnkSkol
-                               , ctev_evtm = EvId (ctev_evar fl)
-                               , ctev_pred = ctev_pred fl }
-                  this_given = cc { cc_ev = gfl }
-              in this_given : rest_givens
-            | otherwise = rest_givens 
-
-        pushable_wanted :: Ct -> Bool 
-        pushable_wanted cc 
-         | isWantedCt cc 
-         = isEqPred (ctPred cc) -- see Note [Preparing inert set for implications]
-         | otherwise = False 
-
 solveImplication :: TcTyVarSet     -- Untouchable TcS unification variables
                  -> Implication    -- Wanted
                  -> TcS (Cts,      -- All wanted or derived floated equalities: var = type
@@ -934,19 +910,17 @@ solveImplication tcs_untouchables
        ; MASSERT (isEmptyBag impls_from_givens)
          
          -- Simplify the wanteds
-       ; (_flat_subst, 
-           WC { wc_flat = unsolved_flats
-              , wc_impl = unsolved_implics
-              , wc_insol = insols }) <- solve_wanteds wanteds
-          -- NB: Not solveWanteds because we need the derived equalities,            
-          -- which may not be solvable (due to touchability) in this implication
-          -- but may become solvable by spontantenous unification outside. 
+       ; WC { wc_flat = unsolved_flats
+            , wc_impl = unsolved_implics
+            , wc_insol = insols } <- solve_wanteds wanteds
 
        ; let (res_flat_free, res_flat_bound)
                  = floatEqualities skols givens unsolved_flats
-             final_flat = keepWanted res_flat_bound
 
-       ; let res_wanted = WC { wc_flat  = final_flat
+       ; let res_wanted = WC { wc_flat  = keepWanted $ res_flat_bound
+                               -- I think this keepWanted must eventually go away, but it is
+                               -- a real code-breaking change. 
+                               -- See Note [KeepWanted in SolveImplication]
                              , wc_impl  = unsolved_implics
                              , wc_insol = insols }
 
@@ -964,6 +938,82 @@ solveImplication tcs_untouchables
        ; return (res_flat_free, res_implic) }
     -- and we are back to the original inerts
 
+\end{code}
+
+Note [KeepWanted in SolveWanteds]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Why do we have:
+   let all_flats = flats `unionBags` keepWanted insols
+instead of the simpler:
+   let all_flats = flats `unionBags` insols
+in solve_wanteds?
+
+Assume a top-level class and instance declaration:
+
+  class D a b | a -> b 
+  instance D [a] [a] 
+
+Assume we have started with an implication:
+
+  forall c. Eq c => { wc_flat = D [c] c [W] }
+
+which we have simplified to:
+
+  forall c. Eq c => { wc_flat = D [c] c [W]
+                    , wc_insols = (c ~ [c]) [D] }
+
+For some reason, e.g. because we floated an equality somewhere else,
+we might try to re-solve this implication. If we do not do a
+keepWanted, then we will end up trying to solve the following
+constraints the second time:
+
+  (D [c] c) [W]
+  (c ~ [c]) [D]
+
+which will result in two Deriveds to end up in the insoluble set:
+
+  wc_flat   = D [c] c [W]
+  wc_insols = (c ~ [c]) [D], (c ~ [c]) [D]
+
+which can result in reporting the same error twice.  
+
+So, do we /lose/ some potentially useful information by doing this? 
+
+No, because the insoluble Derived/Given are going to be equalities, 
+which are going to be derivable anyway from the rest of the flat 
+constraints. 
+
+
+Note [KeepWanted in SolveImplication]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Here is a real example, 
+stripped off from libraries/utf8-string/Codec/Binary/UTF8/Generic.hs
+
+  class C a b | a -> b
+  g :: C a b => a -> b -> () 
+  f :: C a b => a -> b -> () 
+  f xa xb = 
+      let loop = g xa 
+      in loop xb
+
+We will first try to infer a type for loop, and we will succeed:
+    C a b' => b' -> ()
+Subsequently, we will type check (loop xb) and all is good. But, 
+recall that we have to solve a final implication constraint: 
+    C a b => (C a b' => .... cts from body of loop .... )) 
+And now we have a problem as we will generate an equality b ~ b' and fail to 
+solve it. 
+
+I actually think this is a legitimate behaviour (to fail). After all, if we had 
+given the inferred signature to foo we would have failed as well, but we have to 
+find a workaround because library code breaks.
+
+For now I keep the 'keepWanted' though it seems problematic e.g. we might discard 
+a useful Derived!
+
+\begin{code}
+
 
 floatEqualities :: [TcTyVar] -> [EvVar] -> Cts -> (Cts, Cts)
 -- Post: The returned FlavoredEvVar's are only Wanted or Derived
@@ -1259,28 +1309,42 @@ and `?x :: Char` never exist in the same context, so they don't get to
 interact to cause failure.
 \begin{code}
 
-solveCTyFunEqs :: Cts -> TcS (TvSubst, Cts)
--- Default equalities (F xi ~ alpha) by setting (alpha := F xi), whenever possible
--- See Note [Solving Family Equations]
--- Returns: a bunch of unsolved constraints from the original Cts and implications
---          where the newly generated equalities (alpha := F xi) have been substituted through.
-solveCTyFunEqs cts
- = do { untch   <- getUntouchables 
-      ; let (unsolved_can_cts, (ni_subst, cv_binds))
-                = getSolvableCTyFunEqs untch cts
-      ; traceTcS "defaultCTyFunEqs" (vcat [text "Trying to default family equations:"
-                                          , ppr ni_subst, ppr cv_binds
-                                          ])
-      ; mapM_ solve_one cv_binds
-
-      ; return (niFixTvSubst ni_subst, unsolved_can_cts) }
-  where
-    solve_one (Wanted { ctev_evar = cv }, tv, ty) 
-      = setWantedTyBind tv ty >> setEvBind cv (EvCoercion (mkTcReflCo ty))
-    solve_one (Derived {}, tv, ty)
-      = setWantedTyBind tv ty
-    solve_one arg
-      = pprPanic "solveCTyFunEqs: can't solve a /given/ family equation!" $ ppr arg
+
+
+unFlattenWC :: WantedConstraints -> TcS WantedConstraints
+unFlattenWC wc 
+  = do { (subst, remaining_unsolved_flats) <- solveCTyFunEqs (wc_flat wc)
+                -- See Note [Solving Family Equations]
+                -- NB: remaining_flats has already had subst applied
+       ; return $ 
+         WC { wc_flat  = mapBag (substCt subst) remaining_unsolved_flats
+            , wc_impl  = mapBag (substImplication subst) (wc_impl wc) 
+            , wc_insol = mapBag (substCt subst) (wc_insol wc) }
+       }
+  where 
+    solveCTyFunEqs :: Cts -> TcS (TvSubst, Cts)
+    -- Default equalities (F xi ~ alpha) by setting (alpha := F xi), whenever possible
+    -- See Note [Solving Family Equations]
+    -- Returns: a bunch of unsolved constraints from the original Cts and implications
+    --          where the newly generated equalities (alpha := F xi) have been substituted through.
+    solveCTyFunEqs cts
+     = do { untch   <- getUntouchables 
+          ; let (unsolved_can_cts, (ni_subst, cv_binds))
+                    = getSolvableCTyFunEqs untch cts
+          ; traceTcS "defaultCTyFunEqs" (vcat [text "Trying to default family equations:"
+                                              , ppr ni_subst, ppr cv_binds
+                                              ])
+          ; mapM_ solve_one cv_binds
+
+          ; return (niFixTvSubst ni_subst, unsolved_can_cts) }
+      where
+        solve_one (Wanted { ctev_evar = cv }, tv, ty) 
+          = setWantedTyBind tv ty >> setEvBind cv (EvCoercion (mkTcReflCo ty))
+        solve_one (Derived {}, tv, ty)
+          = setWantedTyBind tv ty
+        solve_one arg
+          = pprPanic "solveCTyFunEqs: can't solve a /given/ family equation!" $ ppr arg
+
 ------------
 type FunEqBinds = (TvSubstEnv, [(CtEvidence, TcTyVar, TcType)])
   -- The TvSubstEnv is not idempotent, but is loop-free
@@ -1355,10 +1419,10 @@ When is it ok to do so?
 *                                                                               *
 *********************************************************************************
 \begin{code}
-applyDefaultingRules :: Cts      -- All wanteds
-                     -> TcS Cts  -- All wanteds again!
--- Return some *extra* givens, which express the 
--- type-class-default choice
+applyDefaultingRules :: Cts      -- Wanteds or Deriveds
+                     -> TcS Cts  -- Derived equalities 
+-- Return some extra derived equalities, which express the
+-- type-class default choice. 
 applyDefaultingRules wanteds
   | isEmptyBag wanteds 
   = return emptyBag
@@ -1441,7 +1505,7 @@ defaultTyVar the_tv
        ; implics_from_defaulting <- solveInteractCts cts
        ; MASSERT (isEmptyBag implics_from_defaulting)
          
-       ; (_,unsolved) <- extractUnsolvedTcS
+       ; unsolved <- getTcSInerts >>= (return . getInertUnsolved)
        ; if isEmptyBag (keepWanted unsolved) then return (listToBag cts)
          else return emptyBag }
   | otherwise = return emptyBag	 -- The common case
@@ -1485,7 +1549,7 @@ default is default_k we do not simply generate [D] (k ~ default_k) because:
 findDefaultableGroups 
     :: ( [Type]
        , (Bool,Bool) )  -- (Overloaded strings, extended default rules)
-    -> Cts	-- Unsolved
+    -> Cts	        -- Unsolved (wanted or derived)
     -> [[(Ct,TcTyVar)]]
 findDefaultableGroups (default_tys, (ovl_strings, extended_defaults)) wanteds
   | null default_tys             = []
@@ -1557,7 +1621,7 @@ disambigGroup (default_ty:default_tys) group
                            -- I am not certain if any implications can be generated
                            -- but I am letting this fail aggressively if this ever happens.
                                      
-                       ; (_,unsolved) <- extractUnsolvedTcS 
+                       ; unsolved <- getTcSInerts >>= (return . getInertUnsolved)  
                        ; traceTcS "disambigGroup (solving) }" $
                          text "disambigGroup unsolved =" <+> ppr (keepWanted unsolved)
                        ; if isEmptyBag (keepWanted unsolved) then -- Don't care about Derived's
diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index 6d48c20287..5784788970 100644
--- a/compiler/typecheck/TcTyClsDecls.lhs
+++ b/compiler/typecheck/TcTyClsDecls.lhs
@@ -147,7 +147,11 @@ tcTyClGroup boot_details tyclds
            -- expects well-formed TyCons
        ; tcExtendGlobalEnv tyclss $ do
        { traceTc "Starting validity check" (ppr tyclss)
-       ; mapM_ (addLocM checkValidTyCl) (flattenTyClDecls tyclds)
+       ; mapM_ (recoverM (return ()) . addLocM checkValidTyCl) 
+               (flattenTyClDecls tyclds)
+           -- We recover, which allows us to report multiple validity errors
+           -- even from successive groups.  But we stop after all groups are
+           -- processed if we find any errors.
 
            -- Step 4: Add the implicit things;
            -- we want them in the environment because
diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs
index abc172e1c9..ba397a0568 100644
--- a/compiler/utils/Outputable.lhs
+++ b/compiler/utils/Outputable.lhs
@@ -38,7 +38,6 @@ module Outputable (
         colBinder, bold, keyword,
 
         -- * Converting 'SDoc' into strings and outputing it
-        hPrintDump,
         printForC, printForAsm, printForUser, printForUserPartWay,
         pprCode, mkCodeStyle,
         showSDoc, showSDocOneLine,
@@ -91,7 +90,7 @@ import qualified Data.IntMap as IM
 import Data.Set (Set)
 import qualified Data.Set as Set
 import Data.Word
-import System.IO        ( Handle, hFlush )
+import System.IO        ( Handle )
 import System.FilePath
 
 
@@ -330,13 +329,6 @@ ifPprDebug d = SDoc $ \ctx ->
 \end{code}
 
 \begin{code}
-hPrintDump :: DynFlags -> Handle -> SDoc -> IO ()
-hPrintDump dflags h doc = do
-   Pretty.printDoc PageMode (pprCols dflags) h
-     (runSDoc better_doc (initSDocContext dflags defaultDumpStyle))
-   hFlush h
- where
-   better_doc = doc $$ blankLine
 
 printForUser :: DynFlags -> Handle -> PrintUnqualified -> SDoc -> IO ()
 printForUser dflags handle unqual doc