Merge branch 'master' into late-lam-lift

It seems to be building, but I haven't tested it yet -- just now
commiting before I run validate.sh

Conflicts:
	compiler/basicTypes/VarEnv.lhs
	compiler/codeGen/StgCmmArgRep.hs
	compiler/codeGen/StgCmmHeap.hs
	compiler/coreSyn/CorePrep.lhs
	compiler/coreSyn/CoreUnfold.lhs
	compiler/main/DynFlags.hs
	compiler/main/StaticFlags.hs
	compiler/simplCore/SetLevels.lhs
	compiler/simplCore/SimplCore.lhs
	compiler/specialise/SpecConstr.lhs
	compiler/stgSyn/CoreToStg.lhs
	compiler/stranal/WwLib.lhs
	includes/Cmm.h
	rts/Linker.c

25 files changed, 1269 insertions, 334 deletions

diff --git a/compiler/utils/Bag.lhs b/compiler/utils/Bag.lhs
index a83397898e..2d823e46bb 100644
--- a/compiler/utils/Bag.lhs
+++ b/compiler/utils/Bag.lhs
@@ -21,8 +21,6 @@ module Bag (
         mapAndUnzipBagM, mapAccumBagLM
     ) where
 
-#include "Typeable.h"
-
 import Outputable
 import Util
 
diff --git a/compiler/utils/Binary.hs b/compiler/utils/Binary.hs
index e07577776a..332bfc8e0c 100644
--- a/compiler/utils/Binary.hs
+++ b/compiler/utils/Binary.hs
@@ -20,7 +20,6 @@ module Binary
     {-type-}  BinHandle,
     SymbolTable, Dictionary,
 
-   openBinIO, openBinIO_,
    openBinMem,
 --   closeBin,
 
@@ -87,7 +86,7 @@ import System.IO as IO
 import System.IO.Unsafe         ( unsafeInterleaveIO )
 import System.IO.Error          ( mkIOError, eofErrorType )
 import GHC.Real                 ( Ratio(..) )
-import GHC.Exts
+import ExtsCompat46
 import GHC.Word                 ( Word8(..) )
 
 import GHC.IO ( IO(..) )
@@ -108,15 +107,6 @@ data BinHandle
         -- XXX: should really store a "high water mark" for dumping out
         -- the binary data to a file.
 
-  | BinIO {                     -- binary data stored in a file
-     bh_usr :: UserData,
-     _off_r :: !FastMutInt,     -- the current offset (cached)
-     _hdl   :: !IO.Handle       -- the file handle (must be seekable)
-   }
-        -- cache the file ptr in BinIO; using hTell is too expensive
-        -- to call repeatedly.  If anyone else is modifying this Handle
-        -- at the same time, we'll be screwed.
-
 getUserData :: BinHandle -> UserData
 getUserData bh = bh_usr bh
 
@@ -155,15 +145,6 @@ putAt bh p x = do seekBin bh p; put_ bh x; return ()
 getAt  :: Binary a => BinHandle -> Bin a -> IO a
 getAt bh p = do seekBin bh p; get bh
 
-openBinIO_ :: IO.Handle -> IO BinHandle
-openBinIO_ h = openBinIO h
-
-openBinIO :: IO.Handle -> IO BinHandle
-openBinIO h = do
-  r <- newFastMutInt
-  writeFastMutInt r 0
-  return (BinIO noUserData r h)
-
 openBinMem :: Int -> IO BinHandle
 openBinMem size
  | size <= 0 = error "Data.Binary.openBinMem: size must be >= 0"
@@ -177,13 +158,9 @@ openBinMem size
    return (BinMem noUserData ix_r sz_r arr_r)
 
 tellBin :: BinHandle -> IO (Bin a)
-tellBin (BinIO  _ r _)   = do ix <- readFastMutInt r; return (BinPtr ix)
 tellBin (BinMem _ r _ _) = do ix <- readFastMutInt r; return (BinPtr ix)
 
 seekBin :: BinHandle -> Bin a -> IO ()
-seekBin (BinIO _ ix_r h) (BinPtr p) = do
-  writeFastMutInt ix_r p
-  hSeek h AbsoluteSeek (fromIntegral p)
 seekBin h@(BinMem _ ix_r sz_r _) (BinPtr p) = do
   sz <- readFastMutInt sz_r
   if (p >= sz)
@@ -191,11 +168,6 @@ seekBin h@(BinMem _ ix_r sz_r _) (BinPtr p) = do
         else writeFastMutInt ix_r p
 
 seekBy :: BinHandle -> Int -> IO ()
-seekBy (BinIO _ ix_r h) off = do
-  ix <- readFastMutInt ix_r
-  let ix' = ix + off
-  writeFastMutInt ix_r ix'
-  hSeek h AbsoluteSeek (fromIntegral ix')
 seekBy h@(BinMem _ ix_r sz_r _) off = do
   sz <- readFastMutInt sz_r
   ix <- readFastMutInt ix_r
@@ -209,10 +181,8 @@ isEOFBin (BinMem _ ix_r sz_r _) = do
   ix <- readFastMutInt ix_r
   sz <- readFastMutInt sz_r
   return (ix >= sz)
-isEOFBin (BinIO _ _ h) = hIsEOF h
 
 writeBinMem :: BinHandle -> FilePath -> IO ()
-writeBinMem (BinIO _ _ _) _ = error "Data.Binary.writeBinMem: not a memory handle"
 writeBinMem (BinMem _ ix_r _ arr_r) fn = do
   h <- openBinaryFile fn WriteMode
   arr <- readIORef arr_r
@@ -239,7 +209,6 @@ readBinMem filename = do
   return (BinMem noUserData ix_r sz_r arr_r)
 
 fingerprintBinMem :: BinHandle -> IO Fingerprint
-fingerprintBinMem (BinIO _ _ _) = error "Binary.md5BinMem: not a memory handle"
 fingerprintBinMem (BinMem _ ix_r _ arr_r) = do
   arr <- readIORef arr_r
   ix <- readFastMutInt ix_r
@@ -265,11 +234,9 @@ expandBin (BinMem _ _ sz_r arr_r) off = do
    arr' <- mallocForeignPtrBytes sz'
    withForeignPtr arr $ \old ->
      withForeignPtr arr' $ \new ->
-       copyBytes new old sz 
+       copyBytes new old sz
    writeFastMutInt sz_r sz'
    writeIORef arr_r arr'
-expandBin (BinIO _ _ _) _ = return ()
--- no need to expand a file, we'll assume they expand by themselves.
 
 -- -----------------------------------------------------------------------------
 -- Low-level reading/writing of bytes
@@ -286,11 +253,6 @@ putWord8 h@(BinMem _ ix_r sz_r arr_r) w = do
                 withForeignPtr arr $ \p -> pokeByteOff p ix w
                 writeFastMutInt ix_r (ix+1)
                 return ()
-putWord8 (BinIO _ ix_r h) w = do
-    ix <- readFastMutInt ix_r
-    hPutChar h (chr (fromIntegral w)) -- XXX not really correct
-    writeFastMutInt ix_r (ix+1)
-    return ()
 
 getWord8 :: BinHandle -> IO Word8
 getWord8 (BinMem _ ix_r sz_r arr_r) = do
@@ -302,11 +264,6 @@ getWord8 (BinMem _ ix_r sz_r arr_r) = do
     w <- withForeignPtr arr $ \p -> peekByteOff p ix
     writeFastMutInt ix_r (ix+1)
     return w
-getWord8 (BinIO _ ix_r h) = do
-    ix <- readFastMutInt ix_r
-    c <- hGetChar h
-    writeFastMutInt ix_r (ix+1)
-    return $! (fromIntegral (ord c)) -- XXX not really correct
 
 putByte :: BinHandle -> Word8 -> IO ()
 putByte bh w = put_ bh w
@@ -639,7 +596,11 @@ lazyGet :: Binary a => BinHandle -> IO a
 lazyGet bh = do
     p <- get bh -- a BinPtr
     p_a <- tellBin bh
-    a <- unsafeInterleaveIO (getAt bh p_a)
+    a <- unsafeInterleaveIO $ do
+        -- NB: Use a fresh off_r variable in the child thread, for thread
+        -- safety.
+        off_r <- newFastMutInt
+        getAt bh { _off_r = off_r } p_a
     seekBin bh p -- skip over the object for now
     return a
 
@@ -667,8 +628,8 @@ newReadState get_name get_fs
                ud_put_name = undef "put_name",
                ud_put_fs   = undef "put_fs"
              }
-   
-newWriteState :: (BinHandle -> Name       -> IO ()) 
+
+newWriteState :: (BinHandle -> Name       -> IO ())
               -> (BinHandle -> FastString -> IO ())
               -> UserData
 newWriteState put_name put_fs
@@ -784,3 +745,144 @@ instance Binary FunctionOrData where
           1 -> return IsData
           _ -> panic "Binary FunctionOrData"
 
+instance Binary TupleSort where
+    put_ bh BoxedTuple      = putByte bh 0
+    put_ bh UnboxedTuple    = putByte bh 1
+    put_ bh ConstraintTuple = putByte bh 2
+    get bh = do
+      h <- getByte bh
+      case h of
+        0 -> do return BoxedTuple
+        1 -> do return UnboxedTuple
+        _ -> do return ConstraintTuple
+
+instance Binary Activation where
+    put_ bh NeverActive = do
+            putByte bh 0
+    put_ bh AlwaysActive = do
+            putByte bh 1
+    put_ bh (ActiveBefore aa) = do
+            putByte bh 2
+            put_ bh aa
+    put_ bh (ActiveAfter ab) = do
+            putByte bh 3
+            put_ bh ab
+    get bh = do
+            h <- getByte bh
+            case h of
+              0 -> do return NeverActive
+              1 -> do return AlwaysActive
+              2 -> do aa <- get bh
+                      return (ActiveBefore aa)
+              _ -> do ab <- get bh
+                      return (ActiveAfter ab)
+
+instance Binary InlinePragma where
+    put_ bh (InlinePragma a b c d) = do
+            put_ bh a
+            put_ bh b
+            put_ bh c
+            put_ bh d
+
+    get bh = do
+           a <- get bh
+           b <- get bh
+           c <- get bh
+           d <- get bh
+           return (InlinePragma a b c d)
+
+instance Binary RuleMatchInfo where
+    put_ bh FunLike = putByte bh 0
+    put_ bh ConLike = putByte bh 1
+    get bh = do
+            h <- getByte bh
+            if h == 1 then return ConLike
+                      else return FunLike
+
+instance Binary InlineSpec where
+    put_ bh EmptyInlineSpec = putByte bh 0
+    put_ bh Inline          = putByte bh 1
+    put_ bh Inlinable       = putByte bh 2
+    put_ bh NoInline        = putByte bh 3
+
+    get bh = do h <- getByte bh
+                case h of
+                  0 -> return EmptyInlineSpec
+                  1 -> return Inline
+                  2 -> return Inlinable
+                  _ -> return NoInline
+
+instance Binary DefMethSpec where
+    put_ bh NoDM      = putByte bh 0
+    put_ bh VanillaDM = putByte bh 1
+    put_ bh GenericDM = putByte bh 2
+    get bh = do
+            h <- getByte bh
+            case h of
+              0 -> return NoDM
+              1 -> return VanillaDM
+              _ -> return GenericDM
+
+instance Binary RecFlag where
+    put_ bh Recursive = do
+            putByte bh 0
+    put_ bh NonRecursive = do
+            putByte bh 1
+    get bh = do
+            h <- getByte bh
+            case h of
+              0 -> do return Recursive
+              _ -> do return NonRecursive
+
+instance Binary OverlapFlag where
+    put_ bh (NoOverlap  b) = putByte bh 0 >> put_ bh b
+    put_ bh (OverlapOk  b) = putByte bh 1 >> put_ bh b
+    put_ bh (Incoherent b) = putByte bh 2 >> put_ bh b
+    get bh = do
+        h <- getByte bh
+        b <- get bh
+        case h of
+            0 -> return $ NoOverlap b
+            1 -> return $ OverlapOk b
+            2 -> return $ Incoherent b
+            _ -> panic ("get OverlapFlag " ++ show h)
+
+instance Binary FixityDirection where
+    put_ bh InfixL = do
+            putByte bh 0
+    put_ bh InfixR = do
+            putByte bh 1
+    put_ bh InfixN = do
+            putByte bh 2
+    get bh = do
+            h <- getByte bh
+            case h of
+              0 -> do return InfixL
+              1 -> do return InfixR
+              _ -> do return InfixN
+
+instance Binary Fixity where
+    put_ bh (Fixity aa ab) = do
+            put_ bh aa
+            put_ bh ab
+    get bh = do
+          aa <- get bh
+          ab <- get bh
+          return (Fixity aa ab)
+
+instance Binary WarningTxt where
+    put_ bh (WarningTxt w) = do
+            putByte bh 0
+            put_ bh w
+    put_ bh (DeprecatedTxt d) = do
+            putByte bh 1
+            put_ bh d
+
+    get bh = do
+            h <- getByte bh
+            case h of
+              0 -> do w <- get bh
+                      return (WarningTxt w)
+              _ -> do d <- get bh
+                      return (DeprecatedTxt d)
+
diff --git a/compiler/utils/BooleanFormula.hs b/compiler/utils/BooleanFormula.hs
new file mode 100644
index 0000000000..8620ef555d
--- /dev/null
+++ b/compiler/utils/BooleanFormula.hs
@@ -0,0 +1,211 @@
+--------------------------------------------------------------------------------
+-- | Boolean formulas without quantifiers and without negation.
+-- Such a formula consists of variables, conjunctions (and), and disjunctions (or).
+--
+-- This module is used to represent minimal complete definitions for classes.
+--
+{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveFoldable,
+             DeriveTraversable #-}
+
+module BooleanFormula (
+        BooleanFormula(..),
+        mkFalse, mkTrue, mkAnd, mkOr, mkVar,
+        isFalse, isTrue,
+        eval, simplify, isUnsatisfied,
+        implies, impliesAtom,
+        pprBooleanFormula, pprBooleanFormulaNice
+  ) where
+
+import Data.List ( nub, intersperse )
+import Data.Data
+import Data.Foldable ( Foldable )
+import Data.Traversable ( Traversable )
+
+import MonadUtils
+import Outputable
+import Binary
+
+----------------------------------------------------------------------
+-- Boolean formula type and smart constructors
+----------------------------------------------------------------------
+
+data BooleanFormula a = Var a | And [BooleanFormula a] | Or [BooleanFormula a]
+  deriving (Eq, Data, Typeable, Functor, Foldable, Traversable)
+
+mkVar :: a -> BooleanFormula a
+mkVar = Var
+
+mkFalse, mkTrue :: BooleanFormula a
+mkFalse = Or []
+mkTrue = And []
+
+-- Convert a Bool to a BooleanFormula
+mkBool :: Bool -> BooleanFormula a
+mkBool False = mkFalse
+mkBool True  = mkTrue
+
+-- Make a conjunction, and try to simplify
+mkAnd :: Eq a => [BooleanFormula a] -> BooleanFormula a
+mkAnd = maybe mkFalse (mkAnd' . nub) . concatMapM fromAnd
+  where
+  -- See Note [Simplification of BooleanFormulas]
+  fromAnd :: BooleanFormula a -> Maybe [BooleanFormula a]
+  fromAnd (And xs) = Just xs
+     -- assume that xs are already simplified
+     -- otherwise we would need: fromAnd (And xs) = concat <$> traverse fromAnd xs
+  fromAnd (Or []) = Nothing -- in case of False we bail out, And [..,mkFalse,..] == mkFalse
+  fromAnd x = Just [x]
+  mkAnd' [x] = x
+  mkAnd' xs = And xs
+
+mkOr :: Eq a => [BooleanFormula a] -> BooleanFormula a
+mkOr = maybe mkTrue (mkOr' . nub) . concatMapM fromOr
+  where
+  -- See Note [Simplification of BooleanFormulas]
+  fromOr (Or xs) = Just xs
+  fromOr (And []) = Nothing
+  fromOr x = Just [x]
+  mkOr' [x] = x
+  mkOr' xs = Or xs
+
+
+{-
+Note [Simplification of BooleanFormulas]
+~~~~~~~~~~~~~~~~~~~~~~
+The smart constructors (`mkAnd` and `mkOr`) do some attempt to simplify expressions. In particular,
+ 1. Collapsing nested ands and ors, so
+     `(mkAnd [x, And [y,z]]`
+    is represented as
+     `And [x,y,z]`
+    Implemented by `fromAnd`/`fromOr`
+ 2. Collapsing trivial ands and ors, so
+     `mkAnd [x]` becomes just `x`.
+    Implemented by mkAnd' / mkOr'
+ 3. Conjunction with false, disjunction with true is simplified, i.e.
+     `mkAnd [mkFalse,x]` becomes `mkFalse`.
+ 4. Common subexpresion elimination:
+     `mkAnd [x,x,y]` is reduced to just `mkAnd [x,y]`.
+
+This simplification is not exhaustive, in the sense that it will not produce
+the smallest possible equivalent expression. For example,
+`Or [And [x,y], And [x]]` could be simplified to `And [x]`, but it currently
+is not. A general simplifier would need to use something like BDDs.
+
+The reason behind the (crude) simplifier is to make for more user friendly
+error messages. E.g. for the code
+  > class Foo a where
+  >     {-# MINIMAL bar, (foo, baq | foo, quux) #-}
+  > instance Foo Int where
+  >     bar = ...
+  >     baz = ...
+  >     quux = ...
+We don't show a ridiculous error message like
+    Implement () and (either (`foo' and ()) or (`foo' and ()))
+-}
+
+----------------------------------------------------------------------
+-- Evaluation and simplification
+----------------------------------------------------------------------
+
+isFalse :: BooleanFormula a -> Bool
+isFalse (Or []) = True
+isFalse _ = False
+
+isTrue :: BooleanFormula a -> Bool
+isTrue (And []) = True
+isTrue _ = False
+
+eval :: (a -> Bool) -> BooleanFormula a -> Bool
+eval f (Var x)  = f x
+eval f (And xs) = all (eval f) xs
+eval f (Or xs)  = any (eval f) xs
+
+-- Simplify a boolean formula.
+-- The argument function should give the truth of the atoms, or Nothing if undecided.
+simplify :: Eq a => (a -> Maybe Bool) -> BooleanFormula a -> BooleanFormula a
+simplify f (Var a) = case f a of
+  Nothing -> Var a
+  Just b  -> mkBool b
+simplify f (And xs) = mkAnd (map (simplify f) xs)
+simplify f (Or xs) = mkOr (map (simplify f) xs)
+
+-- Test if a boolean formula is satisfied when the given values are assigned to the atoms
+-- if it is, returns Nothing
+-- if it is not, return (Just remainder)
+isUnsatisfied :: Eq a => (a -> Bool) -> BooleanFormula a -> Maybe (BooleanFormula a)
+isUnsatisfied f bf
+    | isTrue bf' = Nothing
+    | otherwise  = Just bf'
+  where
+  f' x = if f x then Just True else Nothing
+  bf' = simplify f' bf
+
+-- prop_simplify:
+--   eval f x == True   <==>  isTrue  (simplify (Just . f) x)
+--   eval f x == False  <==>  isFalse (simplify (Just . f) x)
+
+-- If the boolean formula holds, does that mean that the given atom is always true?
+impliesAtom :: Eq a => BooleanFormula a -> a -> Bool
+Var x  `impliesAtom` y = x == y
+And xs `impliesAtom` y = any (`impliesAtom` y) xs -- we have all of xs, so one of them implying y is enough
+Or  xs `impliesAtom` y = all (`impliesAtom` y) xs
+
+implies :: Eq a => BooleanFormula a -> BooleanFormula a -> Bool
+x `implies` Var y  = x `impliesAtom` y
+x `implies` And ys = all (x `implies`) ys
+x `implies` Or ys  = any (x `implies`) ys
+
+----------------------------------------------------------------------
+-- Pretty printing
+----------------------------------------------------------------------
+
+-- Pretty print a BooleanFormula,
+-- using the arguments as pretty printers for Var, And and Or respectively
+pprBooleanFormula' :: (Rational -> a -> SDoc)
+                   -> (Rational -> [SDoc] -> SDoc)
+                   -> (Rational -> [SDoc] -> SDoc)
+                   -> Rational -> BooleanFormula a -> SDoc
+pprBooleanFormula' pprVar pprAnd pprOr = go
+  where
+  go p (Var x)  = pprVar p x
+  go p (And []) = cparen (p > 0) $ empty
+  go p (And xs) = pprAnd p (map (go 3) xs)
+  go _ (Or  []) = keyword $ text "FALSE"
+  go p (Or  xs) = pprOr p (map (go 2) xs)
+
+-- Pretty print in source syntax, "a | b | c,d,e"
+pprBooleanFormula :: (Rational -> a -> SDoc) -> Rational -> BooleanFormula a -> SDoc
+pprBooleanFormula pprVar = pprBooleanFormula' pprVar pprAnd pprOr
+  where
+  pprAnd p = cparen (p > 3) . fsep . punctuate comma
+  pprOr  p = cparen (p > 2) . fsep . intersperse (text "|")
+
+-- Pretty print human in readable format, "either `a' or `b' or (`c', `d' and `e')"?
+pprBooleanFormulaNice :: Outputable a => BooleanFormula a -> SDoc
+pprBooleanFormulaNice = pprBooleanFormula' pprVar pprAnd pprOr 0
+  where
+  pprVar _ = quotes . ppr
+  pprAnd p = cparen (p > 1) . pprAnd'
+  pprAnd' [] = empty
+  pprAnd' [x,y] = x <+> text "and" <+> y
+  pprAnd' xs@(_:_) = fsep (punctuate comma (init xs)) <> text ", and" <+> last xs
+  pprOr p xs = cparen (p > 1) $ text "either" <+> sep (intersperse (text "or") xs)
+
+instance Outputable a => Outputable (BooleanFormula a) where
+  pprPrec = pprBooleanFormula pprPrec
+
+----------------------------------------------------------------------
+-- Binary
+----------------------------------------------------------------------
+
+instance Binary a => Binary (BooleanFormula a) where
+  put_ bh (Var x)  = putByte bh 0 >> put_ bh x
+  put_ bh (And xs) = putByte bh 1 >> put_ bh xs
+  put_ bh (Or  xs) = putByte bh 2 >> put_ bh xs
+
+  get bh = do
+    h <- getByte bh
+    case h of
+      0 -> Var <$> get bh
+      1 -> And <$> get bh
+      _ -> Or  <$> get bh
diff --git a/compiler/utils/BufWrite.hs b/compiler/utils/BufWrite.hs
index c0dda03bbb..f85ea8e792 100644
--- a/compiler/utils/BufWrite.hs
+++ b/compiler/utils/BufWrite.hs
@@ -14,7 +14,7 @@
 -- The above warning supression flag is a temporary kludge.
 -- While working on this module you are encouraged to remove it and
 -- detab the module (please do the detabbing in a separate patch). See
---     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
+--     http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
 -- for details
 
 module BufWrite (
diff --git a/compiler/utils/Digraph.lhs b/compiler/utils/Digraph.lhs
index 9ae84a7897..cc684303b6 100644
--- a/compiler/utils/Digraph.lhs
+++ b/compiler/utils/Digraph.lhs
@@ -7,7 +7,7 @@
 -- The above warning supression flag is a temporary kludge.
 -- While working on this module you are encouraged to remove it and
 -- detab the module (please do the detabbing in a separate patch). See
---     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
+--     http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
 -- for details
 
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -15,7 +15,8 @@ module Digraph(
         Graph, graphFromVerticesAndAdjacency, graphFromEdgedVertices,
 
         SCC(..), Node, flattenSCC, flattenSCCs,
-        stronglyConnCompG, topologicalSortG, dfsTopSortG,
+        stronglyConnCompG, stronglyConnCompFromG,
+        topologicalSortG, dfsTopSortG,
         verticesG, edgesG, hasVertexG,
         reachableG, transposeG,
         outdegreeG, indegreeG,
@@ -254,9 +255,21 @@ edges going from them to earlier ones.
 
 \begin{code}
 stronglyConnCompG :: Graph node -> [SCC node]
-stronglyConnCompG (Graph { gr_int_graph = graph, gr_vertex_to_node = vertex_fn }) = map decode forest
+stronglyConnCompG graph = decodeSccs graph forest
+  where forest = {-# SCC "Digraph.scc" #-} scc (gr_int_graph graph)
+
+-- Find the set of strongly connected components starting from the
+-- given roots.  This is a good way to discard unreachable nodes at
+-- the same time as computing SCCs.
+stronglyConnCompFromG :: Graph node -> [node] -> [SCC node]
+stronglyConnCompFromG graph roots = decodeSccs graph forest
+  where forest = {-# SCC "Digraph.scc" #-} sccFrom (gr_int_graph graph) vs
+        vs = [ v | Just v <- map (gr_node_to_vertex graph) roots ]
+
+decodeSccs :: Graph node -> Forest Vertex -> [SCC node]
+decodeSccs Graph { gr_int_graph = graph, gr_vertex_to_node = vertex_fn } forest
+  = map decode forest
   where
-    forest             = {-# SCC "Digraph.scc" #-} scc graph
     decode (Node v []) | mentions_itself v = CyclicSCC [vertex_fn v]
                        | otherwise         = AcyclicSCC (vertex_fn v)
     decode other = CyclicSCC (dec other [])
@@ -269,11 +282,12 @@ stronglyConnCompFromEdgedVertices
         :: Ord key
         => [Node key payload]
         -> [SCC payload]
-stronglyConnCompFromEdgedVertices = map (fmap get_node) . stronglyConnCompFromEdgedVerticesR
+stronglyConnCompFromEdgedVertices
+  = map (fmap get_node) . stronglyConnCompFromEdgedVerticesR
   where get_node (n, _, _) = n
 
 -- The "R" interface is used when you expect to apply SCC to
--- the (some of) the result of SCC, so you dont want to lose the dependency info
+-- (some of) the result of SCC, so you dont want to lose the dependency info
 stronglyConnCompFromEdgedVerticesR
         :: Ord key
         => [Node key payload]
@@ -534,6 +548,9 @@ postorderF ts = foldr (.) id $ map postorder ts
 postOrd :: IntGraph -> [Vertex]
 postOrd g = postorderF (dff g) []
 
+postOrdFrom :: IntGraph -> [Vertex] -> [Vertex]
+postOrdFrom g vs = postorderF (dfs g vs) []
+
 topSort :: IntGraph -> [Vertex]
 topSort = reverse . postOrd
 \end{code}
@@ -557,6 +574,9 @@ undirected g  = buildG (bounds g) (edges g ++ reverseE g)
 \begin{code}
 scc  :: IntGraph -> Forest Vertex
 scc g = dfs g (reverse (postOrd (transpose g)))
+
+sccFrom  :: IntGraph -> [Vertex] -> Forest Vertex
+sccFrom g vs = reverse (dfs (transpose g) (reverse (postOrdFrom g vs)))
 \end{code}
 
 ------------------------------------------------------------
diff --git a/compiler/utils/Encoding.hs b/compiler/utils/Encoding.hs
index 6467377a1a..c4a669c134 100644
--- a/compiler/utils/Encoding.hs
+++ b/compiler/utils/Encoding.hs
@@ -32,8 +32,7 @@ module Encoding (
 import Foreign
 import Data.Char
 import Numeric
-import GHC.Ptr ( Ptr(..) )
-import GHC.Base
+import ExtsCompat46
 
 -- -----------------------------------------------------------------------------
 -- UTF-8
diff --git a/compiler/utils/ExtsCompat46.hs b/compiler/utils/ExtsCompat46.hs
new file mode 100644
index 0000000000..da0e67ab93
--- /dev/null
+++ b/compiler/utils/ExtsCompat46.hs
@@ -0,0 +1,293 @@
+{-# LANGUAGE BangPatterns, CPP #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  ExtsCompat46
+-- Copyright   :  (c) Lodz University of Technology 2013
+-- License     :  see LICENSE
+--
+-- Maintainer  :  ghc-devs@haskell.org
+-- Stability   :  internal
+-- Portability :  non-portable (GHC internal)
+--
+-- Compatibility module to encapsulate primops API change between GHC 7.6
+-- GHC 7.8.
+--
+-- In GHC we use comparison primops in a couple of modules, but that primops
+-- have different type signature in GHC 7.6 (where they return Bool) than
+-- in GHC 7.8 (where they return Int#). As long as we allow bootstrapping
+-- with GHC 7.6 or earlier we need to have this compatibility module, so that
+-- we can compile stage1 compiler using the old API and then continue with
+-- stage2 using the new API. When we set GHC 7.8 as the minimum version
+-- required for bootstrapping, we should remove this module.
+--
+-----------------------------------------------------------------------------
+
+module ExtsCompat46 (
+    module GHC.Exts,
+
+    gtChar#, geChar#, eqChar#,
+    neChar#, ltChar#, leChar#,
+
+    (>#), (>=#), (==#), (/=#), (<#), (<=#),
+
+    gtWord#, geWord#, eqWord#,
+    neWord#, ltWord#, leWord#,
+
+    (>##), (>=##), (==##), (/=##), (<##), (<=##),
+
+    gtFloat#, geFloat#, eqFloat#,
+    neFloat#, ltFloat#, leFloat#,
+
+    gtAddr#, geAddr#, eqAddr#,
+    neAddr#, ltAddr#, leAddr#,
+
+    sameMutableArray#, sameMutableByteArray#, sameMutableArrayArray#,
+    sameMutVar#, sameTVar#, sameMVar#
+
+ ) where
+
+import GHC.Exts hiding (
+    gtChar#, geChar#, eqChar#,
+    neChar#, ltChar#, leChar#,
+
+    (>#), (>=#), (==#), (/=#), (<#), (<=#),
+
+    gtWord#, geWord#, eqWord#,
+    neWord#, ltWord#, leWord#,
+
+    (>##), (>=##), (==##), (/=##), (<##), (<=##),
+
+    gtFloat#, geFloat#, eqFloat#,
+    neFloat#, ltFloat#, leFloat#,
+
+    gtAddr#, geAddr#, eqAddr#,
+    neAddr#, ltAddr#, leAddr#,
+
+    sameMutableArray#, sameMutableByteArray#, sameMutableArrayArray#,
+    sameMutVar#, sameTVar#, sameMVar#
+ )
+
+import qualified GHC.Exts as E (
+    gtChar#, geChar#, eqChar#,
+    neChar#, ltChar#, leChar#,
+
+    (>#), (>=#), (==#), (/=#), (<#), (<=#),
+
+    gtWord#, geWord#, eqWord#,
+    neWord#, ltWord#, leWord#,
+
+    (>##), (>=##), (==##), (/=##), (<##), (<=##),
+
+    gtFloat#, geFloat#, eqFloat#,
+    neFloat#, ltFloat#, leFloat#,
+
+    gtAddr#, geAddr#, eqAddr#,
+    neAddr#, ltAddr#, leAddr#,
+
+    sameMutableArray#, sameMutableByteArray#, sameMutableArrayArray#,
+    sameMutVar#, sameTVar#, sameMVar#
+ )
+
+-- See #8330
+#if __GLASGOW_HASKELL__ > 710
+#error What is minimal version of GHC required for bootstraping? If it's GHC 7.8 we should remove this module and use GHC.Exts instead.
+#endif
+
+#if __GLASGOW_HASKELL__ > 706
+
+gtChar# :: Char# -> Char# -> Bool
+gtChar# a b = isTrue# (a `E.gtChar#` b)
+geChar# :: Char# -> Char# -> Bool
+geChar# a b = isTrue# (a `E.geChar#` b)
+eqChar# :: Char# -> Char# -> Bool
+eqChar# a b = isTrue# (a `E.eqChar#` b)
+neChar# :: Char# -> Char# -> Bool
+neChar# a b = isTrue# (a `E.neChar#` b)
+ltChar# :: Char# -> Char# -> Bool
+ltChar# a b = isTrue# (a `E.ltChar#` b)
+leChar# :: Char# -> Char# -> Bool
+leChar# a b = isTrue# (a `E.leChar#` b)
+
+infix 4 >#, >=#, ==#, /=#, <#, <=#
+
+(>#) :: Int# -> Int# -> Bool
+(>#) a b = isTrue# (a E.># b)
+(>=#) :: Int# -> Int# -> Bool
+(>=#) a b = isTrue# (a E.>=# b)
+(==#) :: Int# -> Int# -> Bool
+(==#) a b = isTrue# (a E.==# b)
+(/=#) :: Int# -> Int# -> Bool
+(/=#) a b = isTrue# (a E./=# b)
+(<#)  :: Int# -> Int# -> Bool
+(<#) a b = isTrue# (a E.<# b)
+(<=#) :: Int# -> Int# -> Bool
+(<=#) a b = isTrue# (a E.<=# b)
+
+gtWord# :: Word# -> Word# -> Bool
+gtWord# a b = isTrue# (a `E.gtWord#` b)
+geWord# :: Word# -> Word# -> Bool
+geWord# a b = isTrue# (a `E.geWord#` b)
+eqWord# :: Word# -> Word# -> Bool
+eqWord# a b = isTrue# (a `E.eqWord#` b)
+neWord# :: Word# -> Word# -> Bool
+neWord# a b = isTrue# (a `E.neWord#` b)
+ltWord# :: Word# -> Word# -> Bool
+ltWord# a b = isTrue# (a `E.ltWord#` b)
+leWord# :: Word# -> Word# -> Bool
+leWord# a b = isTrue# (a `E.leWord#` b)
+
+infix 4 >##, >=##, ==##, /=##, <##, <=##
+
+(>##)  :: Double# -> Double# -> Bool
+(>##) a b = isTrue# (a E.>## b)
+(>=##) :: Double# -> Double# -> Bool
+(>=##) a b = isTrue# (a E.>=## b)
+(==##) :: Double# -> Double# -> Bool
+(==##) a b = isTrue# (a E.==## b)
+(/=##) :: Double# -> Double# -> Bool
+(/=##) a b = isTrue# (a E./=## b)
+(<##)  :: Double# -> Double# -> Bool
+(<##) a b = isTrue# (a E.<## b)
+(<=##) :: Double# -> Double# -> Bool
+(<=##) a b = isTrue# (a E.<=## b)
+
+gtFloat# :: Float# -> Float# -> Bool
+gtFloat# a b = isTrue# (a `E.gtFloat#` b)
+geFloat# :: Float# -> Float# -> Bool
+geFloat# a b = isTrue# (a `E.geFloat#` b)
+eqFloat# :: Float# -> Float# -> Bool
+eqFloat# a b = isTrue# (a `E.eqFloat#` b)
+neFloat# :: Float# -> Float# -> Bool
+neFloat# a b = isTrue# (a `E.neFloat#` b)
+ltFloat# :: Float# -> Float# -> Bool
+ltFloat# a b = isTrue# (a `E.ltFloat#` b)
+leFloat# :: Float# -> Float# -> Bool
+leFloat# a b = isTrue# (a `E.leFloat#` b)
+
+gtAddr# :: Addr# -> Addr# -> Bool
+gtAddr# a b = isTrue# (a `E.gtAddr#` b)
+geAddr# :: Addr# -> Addr# -> Bool
+geAddr# a b = isTrue# (a `E.geAddr#` b)
+eqAddr# :: Addr# -> Addr# -> Bool
+eqAddr# a b = isTrue# (a `E.eqAddr#` b)
+neAddr# :: Addr# -> Addr# -> Bool
+neAddr# a b = isTrue# (a `E.neAddr#` b)
+ltAddr# :: Addr# -> Addr# -> Bool
+ltAddr# a b = isTrue# (a `E.ltAddr#` b)
+leAddr# :: Addr# -> Addr# -> Bool
+leAddr# a b = isTrue# (a `E.leAddr#` b)
+
+sameMutableArray# :: MutableArray# s a -> MutableArray# s a -> Bool
+sameMutableArray# a b = isTrue# (E.sameMutableArray# a b)
+sameMutableByteArray# :: MutableByteArray# s -> MutableByteArray# s -> Bool
+sameMutableByteArray# a b = isTrue# (E.sameMutableByteArray# a b)
+sameMutableArrayArray# :: MutableArrayArray# s -> MutableArrayArray# s -> Bool
+sameMutableArrayArray# a b = isTrue# (E.sameMutableArrayArray# a b)
+
+sameMutVar# :: MutVar# s a -> MutVar# s a -> Bool
+sameMutVar# a b = isTrue# (E.sameMutVar# a b)
+sameTVar# :: TVar# s a -> TVar# s a -> Bool
+sameTVar# a b = isTrue# (E.sameTVar# a b)
+sameMVar# :: MVar# s a -> MVar# s a -> Bool
+sameMVar# a b = isTrue# (E.sameMVar# a b)
+
+#else
+
+gtChar# :: Char# -> Char# -> Bool
+gtChar# a b = a `E.gtChar#` b
+geChar# :: Char# -> Char# -> Bool
+geChar# a b = a `E.geChar#` b
+eqChar# :: Char# -> Char# -> Bool
+eqChar# a b = a `E.eqChar#` b
+neChar# :: Char# -> Char# -> Bool
+neChar# a b = a `E.neChar#` b
+ltChar# :: Char# -> Char# -> Bool
+ltChar# a b = a `E.ltChar#` b
+leChar# :: Char# -> Char# -> Bool
+leChar# a b = a `E.leChar#` b
+
+infix 4 >#, >=#, ==#, /=#, <#, <=#
+
+(>#)  :: Int# -> Int# -> Bool
+(>#) a b = a E.># b
+(>=#) :: Int# -> Int# -> Bool
+(>=#) a b = a E.>=# b
+(==#) :: Int# -> Int# -> Bool
+(==#) a b = a E.==# b
+(/=#) :: Int# -> Int# -> Bool
+(/=#) a b = a E./=# b
+(<#)  :: Int# -> Int# -> Bool
+(<#) a b = a E.<# b
+(<=#) :: Int# -> Int# -> Bool
+(<=#) a b = a E.<=# b
+
+gtWord# :: Word# -> Word# -> Bool
+gtWord# a b = a `E.gtWord#` b
+geWord# :: Word# -> Word# -> Bool
+geWord# a b = a `E.geWord#` b
+eqWord# :: Word# -> Word# -> Bool
+eqWord# a b = a `E.eqWord#` b
+neWord# :: Word# -> Word# -> Bool
+neWord# a b = a `E.neWord#` b
+ltWord# :: Word# -> Word# -> Bool
+ltWord# a b = a `E.ltWord#` b
+leWord# :: Word# -> Word# -> Bool
+leWord# a b = a `E.leWord#` b
+
+infix 4 >##, >=##, ==##, /=##, <##, <=##
+
+(>##)  :: Double# -> Double# -> Bool
+(>##) a b = a E.>## b
+(>=##) :: Double# -> Double# -> Bool
+(>=##) a b = a E.>=## b
+(==##) :: Double# -> Double# -> Bool
+(==##) a b = a E.==## b
+(/=##) :: Double# -> Double# -> Bool
+(/=##) a b = a E./=## b
+(<##)  :: Double# -> Double# -> Bool
+(<##) a b = a E.<## b
+(<=##) :: Double# -> Double# -> Bool
+(<=##) a b = a E.<=## b
+
+gtFloat# :: Float# -> Float# -> Bool
+gtFloat# a b = a `E.gtFloat#` b
+geFloat# :: Float# -> Float# -> Bool
+geFloat# a b = a `E.geFloat#` b
+eqFloat# :: Float# -> Float# -> Bool
+eqFloat# a b = a `E.eqFloat#` b
+neFloat# :: Float# -> Float# -> Bool
+neFloat# a b = a `E.neFloat#` b
+ltFloat# :: Float# -> Float# -> Bool
+ltFloat# a b = a `E.ltFloat#` b
+leFloat# :: Float# -> Float# -> Bool
+leFloat# a b = a `E.leFloat#` b
+
+gtAddr# :: Addr# -> Addr# -> Bool
+gtAddr# a b = a `E.gtAddr#` b
+geAddr# :: Addr# -> Addr# -> Bool
+geAddr# a b = a `E.geAddr#` b
+eqAddr# :: Addr# -> Addr# -> Bool
+eqAddr# a b = a `E.eqAddr#` b
+neAddr# :: Addr# -> Addr# -> Bool
+neAddr# a b = a `E.neAddr#` b
+ltAddr# :: Addr# -> Addr# -> Bool
+ltAddr# a b = a `E.ltAddr#` b
+leAddr# :: Addr# -> Addr# -> Bool
+leAddr# a b = a `E.leAddr#` b
+
+sameMutableArray# :: MutableArray# s a -> MutableArray# s a -> Bool
+sameMutableArray# a b = E.sameMutableArray# a b
+sameMutableByteArray# :: MutableByteArray# s -> MutableByteArray# s -> Bool
+sameMutableByteArray# a b = E.sameMutableByteArray# a b
+sameMutableArrayArray# :: MutableArrayArray# s -> MutableArrayArray# s -> Bool
+sameMutableArrayArray# a b = E.sameMutableArrayArray# a b
+
+sameMutVar# :: MutVar# s a -> MutVar# s a -> Bool
+sameMutVar# a b = E.sameMutVar# a b
+sameTVar# :: TVar# s a -> TVar# s a -> Bool
+sameTVar# a b = E.sameTVar# a b
+sameMVar# :: MVar# s a -> MVar# s a -> Bool
+sameMVar# a b = E.sameMVar# a b
+
+#endif
\ No newline at end of file
diff --git a/compiler/utils/FastMutInt.lhs b/compiler/utils/FastMutInt.lhs
index d29bb9136c..7156cdc9fb 100644
--- a/compiler/utils/FastMutInt.lhs
+++ b/compiler/utils/FastMutInt.lhs
@@ -1,28 +1,20 @@
 \begin{code}
-{-# OPTIONS -fno-warn-tabs #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and
--- detab the module (please do the detabbing in a separate patch). See
---     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
--- for details
-
 {-# LANGUAGE BangPatterns #-}
 {-# OPTIONS -cpp #-}
 {-# OPTIONS_GHC -O #-}
 -- We always optimise this, otherwise performance of a non-optimised
 -- compiler is severely affected
-
 --
 -- (c) The University of Glasgow 2002-2006
 --
 -- Unboxed mutable Ints
 
 module FastMutInt(
-	FastMutInt, newFastMutInt,
-	readFastMutInt, writeFastMutInt,
+        FastMutInt, newFastMutInt,
+        readFastMutInt, writeFastMutInt,
 
-	FastMutPtr, newFastMutPtr,
-	readFastMutPtr, writeFastMutPtr
+        FastMutPtr, newFastMutPtr,
+        readFastMutPtr, writeFastMutPtr
   ) where
 
 #ifdef __GLASGOW_HASKELL__
diff --git a/compiler/utils/FastString.lhs b/compiler/utils/FastString.lhs
index 1eeab0f561..5a78c0b59b 100644
--- a/compiler/utils/FastString.lhs
+++ b/compiler/utils/FastString.lhs
@@ -10,18 +10,20 @@
 -- |
 -- There are two principal string types used internally by GHC:
 --
--- 'FastString':
---               * A compact, hash-consed, representation of character strings.
---               * Comparison is O(1), and you can get a 'Unique.Unique' from them.
---               * Generated by 'fsLit'.
---               * Turn into 'Outputable.SDoc' with 'Outputable.ftext'.
+-- ['FastString']
 --
--- 'LitString':
---               * Just a wrapper for the @Addr#@ of a C string (@Ptr CChar@).
---               * Practically no operations.
---               * Outputing them is fast.
---               * Generated by 'sLit'.
---               * Turn into 'Outputable.SDoc' with 'Outputable.ptext'
+--   * A compact, hash-consed, representation of character strings.
+--   * Comparison is O(1), and you can get a 'Unique.Unique' from them.
+--   * Generated by 'fsLit'.
+--   * Turn into 'Outputable.SDoc' with 'Outputable.ftext'.
+--
+-- ['LitString']
+--
+--   * Just a wrapper for the @Addr#@ of a C string (@Ptr CChar@).
+--   * Practically no operations.
+--   * Outputing them is fast.
+--   * Generated by 'sLit'.
+--   * Turn into 'Outputable.SDoc' with 'Outputable.ptext'
 --
 -- Use 'LitString' unless you want the facilities of 'FastString'.
 module FastString
@@ -79,17 +81,17 @@ module FastString
 
         -- * LitStrings
         LitString,
-        
+
         -- ** Construction
         sLit,
 #if defined(__GLASGOW_HASKELL__)
         mkLitString#,
 #endif
         mkLitString,
-        
+
         -- ** Deconstruction
         unpackLitString,
-        
+
         -- ** Operations
         lengthLS
        ) where
@@ -102,24 +104,30 @@ import FastFunctions
 import Panic
 import Util
 
+import Control.Monad
 import Data.ByteString (ByteString)
 import qualified Data.ByteString          as BS
 import qualified Data.ByteString.Char8    as BSC
 import qualified Data.ByteString.Internal as BS
 import qualified Data.ByteString.Unsafe   as BS
 import Foreign.C
-import GHC.Exts
+import ExtsCompat46
 import System.IO
 import System.IO.Unsafe ( unsafePerformIO )
 import Data.Data
-import Data.IORef       ( IORef, newIORef, readIORef, writeIORef )
+import Data.IORef       ( IORef, newIORef, readIORef, atomicModifyIORef )
 import Data.Maybe       ( isJust )
 import Data.Char
+import Data.List        ( elemIndex )
 
-import GHC.IO           ( IO(..) )
+import GHC.IO           ( IO(..), unsafeDupablePerformIO )
 
 import Foreign.Safe
 
+#if STAGE >= 2
+import GHC.Conc.Sync    (sharedCAF)
+#endif
+
 #if defined(__GLASGOW_HASKELL__)
 import GHC.Base         ( unpackCString# )
 #endif
@@ -207,116 +215,175 @@ cmpFS f1@(FastString u1 _ _ _) f2@(FastString u2 _ _ _) =
   if u1 == u2 then EQ else
   compare (fastStringToByteString f1) (fastStringToByteString f2)
 
-#ifndef __HADDOCK__
 foreign import ccall unsafe "ghc_memcmp"
   memcmp :: Ptr a -> Ptr b -> Int -> IO Int
-#endif
 
 -- -----------------------------------------------------------------------------
 -- Construction
 
 {-
-Internally, the compiler will maintain a fast string symbol
-table, providing sharing and fast comparison. Creation of
-new @FastString@s then covertly does a lookup, re-using the
-@FastString@ if there was a hit.
--}
+Internally, the compiler will maintain a fast string symbol table, providing
+sharing and fast comparison. Creation of new @FastString@s then covertly does a
+lookup, re-using the @FastString@ if there was a hit.
+
+The design of the FastString hash table allows for lockless concurrent reads
+and updates to multiple buckets with low synchronization overhead.
 
+See Note [Updating the FastString table] on how it's updated.
+-}
 data FastStringTable =
  FastStringTable
-    {-# UNPACK #-} !Int
-    (MutableArray# RealWorld [FastString])
+    {-# UNPACK #-} !(IORef Int)  -- the unique ID counter shared with all buckets
+    (MutableArray# RealWorld (IORef [FastString])) -- the array of mutable buckets
 
+string_table :: FastStringTable
 {-# NOINLINE string_table #-}
-string_table :: IORef FastStringTable
-string_table =
- unsafePerformIO $ do
-   tab <- IO $ \s1# -> case newArray# hASH_TBL_SIZE_UNBOXED [] s1# of
-                           (# s2#, arr# #) ->
-                               (# s2#, FastStringTable 0 arr# #)
-   newIORef tab
-
-lookupTbl :: FastStringTable -> Int -> IO [FastString]
+string_table = unsafePerformIO $ do
+  uid <- newIORef 0
+  tab <- IO $ \s1# -> case newArray# hASH_TBL_SIZE_UNBOXED (panic "string_table") s1# of
+                          (# s2#, arr# #) ->
+                              (# s2#, FastStringTable uid arr# #)
+  forM_ [0.. hASH_TBL_SIZE-1] $ \i -> do
+     bucket <- newIORef []
+     updTbl tab i bucket
+
+  -- use the support wired into the RTS to share this CAF among all images of
+  -- libHSghc
+#if STAGE < 2
+  return tab
+#else
+  sharedCAF tab getOrSetLibHSghcFastStringTable
+
+-- from the RTS; thus we cannot use this mechanism when STAGE<2; the previous
+-- RTS might not have this symbol
+foreign import ccall unsafe "getOrSetLibHSghcFastStringTable"
+  getOrSetLibHSghcFastStringTable :: Ptr a -> IO (Ptr a)
+#endif
+
+{-
+
+We include the FastString table in the `sharedCAF` mechanism because we'd like
+FastStrings created by a Core plugin to have the same uniques as corresponding
+strings created by the host compiler itself.  For example, this allows plugins
+to lookup known names (eg `mkTcOcc "MySpecialType"`) in the GlobalRdrEnv or
+even re-invoke the parser.
+
+In particular, the following little sanity test was failing in a plugin
+prototyping safe newtype-coercions: GHC.NT.Type.NT was imported, but could not
+be looked up /by the plugin/.
+
+   let rdrName = mkModuleName "GHC.NT.Type" `mkRdrQual` mkTcOcc "NT"
+   putMsgS $ showSDoc dflags $ ppr $ lookupGRE_RdrName rdrName $ mg_rdr_env guts
+
+`mkTcOcc` involves the lookup (or creation) of a FastString.  Since the
+plugin's FastString.string_table is empty, constructing the RdrName also
+allocates new uniques for the FastStrings "GHC.NT.Type" and "NT".  These
+uniques are almost certainly unequal to the ones that the host compiler
+originally assigned to those FastStrings.  Thus the lookup fails since the
+domain of the GlobalRdrEnv is affected by the RdrName's OccName's FastString's
+unique.
+
+The old `reinitializeGlobals` mechanism is enough to provide the plugin with
+read-access to the table, but it insufficient in the general case where the
+plugin may allocate FastStrings. This mutates the supply for the FastStrings'
+unique, and that needs to be propagated back to the compiler's instance of the
+global variable.  Such propagation is beyond the `reinitializeGlobals`
+mechanism.
+
+Maintaining synchronization of the two instances of this global is rather
+difficult because of the uses of `unsafePerformIO` in this module.  Not
+synchronizing them risks breaking the rather major invariant that two
+FastStrings with the same unique have the same string. Thus we use the
+lower-level `sharedCAF` mechanism that relies on Globals.c.
+
+-}
+
+lookupTbl :: FastStringTable -> Int -> IO (IORef [FastString])
 lookupTbl (FastStringTable _ arr#) (I# i#) =
   IO $ \ s# -> readArray# arr# i# s#
 
-updTbl :: IORef FastStringTable -> FastStringTable -> Int -> [FastString] -> IO ()
-updTbl fs_table_var (FastStringTable uid arr#) (I# i#) ls = do
+updTbl :: FastStringTable -> Int -> IORef [FastString] -> IO ()
+updTbl (FastStringTable _uid arr#) (I# i#) ls = do
   (IO $ \ s# -> case writeArray# arr# i# ls s# of { s2# -> (# s2#, () #) })
-  writeIORef fs_table_var (FastStringTable (uid+1) arr#)
 
 mkFastString# :: Addr# -> FastString
 mkFastString# a# = mkFastStringBytes ptr (ptrStrLength ptr)
   where ptr = Ptr a#
 
+{- Note [Updating the FastString table]
+
+The procedure goes like this:
+
+1. Read the relevant bucket and perform a look up of the string.
+2. If it exists, return it.
+3. Otherwise grab a unique ID, create a new FastString and atomically attempt
+   to update the relevant bucket with this FastString:
+
+   * Double check that the string is not in the bucket. Another thread may have
+     inserted it while we were creating our string.
+   * Return the existing FastString if it exists. The one we preemptively
+     created will get GCed.
+   * Otherwise, insert and return the string we created.
+-}
+
+{- Note [Double-checking the bucket]
+
+It is not necessary to check the entire bucket the second time. We only have to
+check the strings that are new to the bucket since the last time we read it.
+-}
+
+mkFastStringWith :: (Int -> IO FastString) -> Ptr Word8 -> Int -> IO FastString
+mkFastStringWith mk_fs !ptr !len = do
+    let hash = hashStr ptr len
+    bucket <- lookupTbl string_table hash
+    ls1 <- readIORef bucket
+    res <- bucket_match ls1 len ptr
+    case res of
+        Just v  -> return v
+        Nothing -> do
+            n <- get_uid
+            new_fs <- mk_fs n
+
+            atomicModifyIORef bucket $ \ls2 ->
+                -- Note [Double-checking the bucket]
+                let delta_ls = case ls1 of
+                        []  -> ls2
+                        l:_ -> case l `elemIndex` ls2 of
+                            Nothing  -> panic "mkFastStringWith"
+                            Just idx -> take idx ls2
+
+                -- NB: Might as well use inlinePerformIO, since the call to
+                -- bucket_match doesn't perform any IO that could be floated
+                -- out of this closure or erroneously duplicated.
+                in case inlinePerformIO (bucket_match delta_ls len ptr) of
+                    Nothing -> (new_fs:ls2, new_fs)
+                    Just fs -> (ls2,fs)
+  where
+    !(FastStringTable uid _arr) = string_table
+
+    get_uid = atomicModifyIORef uid $ \n -> (n+1,n)
+
 mkFastStringBytes :: Ptr Word8 -> Int -> FastString
-mkFastStringBytes ptr len = unsafePerformIO $ do
-  ft@(FastStringTable uid _) <- readIORef string_table
-  let
-   h = hashStr ptr len
-   add_it ls = do
-        fs <- copyNewFastString uid ptr len
-        updTbl string_table ft h (fs:ls)
-        {- _trace ("new: " ++ show f_str)   $ -}
-        return fs
-  --
-  lookup_result <- lookupTbl ft h
-  case lookup_result of
-    [] -> add_it []
-    ls -> do
-       b <- bucket_match ls len ptr
-       case b of
-         Nothing -> add_it ls
-         Just v  -> {- _trace ("re-use: "++show v) $ -} return v
+mkFastStringBytes !ptr !len =
+    -- NB: Might as well use unsafeDupablePerformIO, since mkFastStringWith is
+    -- idempotent.
+    unsafeDupablePerformIO $
+        mkFastStringWith (copyNewFastString ptr len) ptr len
 
 -- | Create a 'FastString' from an existing 'ForeignPtr'; the difference
 -- between this and 'mkFastStringBytes' is that we don't have to copy
 -- the bytes if the string is new to the table.
 mkFastStringForeignPtr :: Ptr Word8 -> ForeignPtr Word8 -> Int -> IO FastString
-mkFastStringForeignPtr ptr fp len = do
-  ft@(FastStringTable uid _) <- readIORef string_table
---  _trace ("hashed: "++show (I# h)) $
-  let
-    h = hashStr ptr len
-    add_it ls = do
-        fs <- mkNewFastString uid ptr fp len
-        updTbl string_table ft h (fs:ls)
-        {- _trace ("new: " ++ show f_str)   $ -}
-        return fs
-  --
-  lookup_result <- lookupTbl ft h
-  case lookup_result of
-    [] -> add_it []
-    ls -> do
-       b <- bucket_match ls len ptr
-       case b of
-         Nothing -> add_it ls
-         Just v  -> {- _trace ("re-use: "++show v) $ -} return v
+mkFastStringForeignPtr ptr !fp len
+    = mkFastStringWith (mkNewFastString fp ptr len) ptr len
 
 -- | Create a 'FastString' from an existing 'ForeignPtr'; the difference
 -- between this and 'mkFastStringBytes' is that we don't have to copy
 -- the bytes if the string is new to the table.
 mkFastStringByteString :: ByteString -> IO FastString
 mkFastStringByteString bs = BS.unsafeUseAsCStringLen bs $ \(ptr, len) -> do
-  ft@(FastStringTable uid _) <- readIORef string_table
---  _trace ("hashed: "++show (I# h)) $
-  let
-    ptr' = castPtr ptr
-    h = hashStr ptr' len
-    add_it ls = do
-        fs <- mkNewFastStringByteString uid ptr' len bs
-        updTbl string_table ft h (fs:ls)
-        {- _trace ("new: " ++ show f_str)   $ -}
-        return fs
-  --
-  lookup_result <- lookupTbl ft h
-  case lookup_result of
-    [] -> add_it []
-    ls -> do
-       b <- bucket_match ls len ptr'
-       case b of
-         Nothing -> add_it ls
-         Just v  -> {- _trace ("re-use: "++show v) $ -} return v
+  let ptr' = castPtr ptr
+  mkFastStringWith (mkNewFastStringByteString bs ptr' len) ptr' len
 
 -- | Creates a UTF-8 encoded 'FastString' from a 'String'
 mkFastString :: String -> FastString
@@ -353,22 +420,22 @@ bucket_match (v@(FastString _ _ bs _):ls) len ptr
       | otherwise =
          bucket_match ls len ptr
 
-mkNewFastString :: Int -> Ptr Word8 -> ForeignPtr Word8 -> Int
+mkNewFastString :: ForeignPtr Word8 -> Ptr Word8 -> Int -> Int
                 -> IO FastString
-mkNewFastString uid ptr fp len = do
+mkNewFastString fp ptr len uid = do
   ref <- newIORef Nothing
   n_chars <- countUTF8Chars ptr len
   return (FastString uid n_chars (BS.fromForeignPtr fp 0 len) ref)
 
-mkNewFastStringByteString :: Int -> Ptr Word8 -> Int -> ByteString
+mkNewFastStringByteString :: ByteString -> Ptr Word8 -> Int -> Int
                           -> IO FastString
-mkNewFastStringByteString uid ptr len bs = do
+mkNewFastStringByteString bs ptr len uid = do
   ref <- newIORef Nothing
   n_chars <- countUTF8Chars ptr len
   return (FastString uid n_chars bs ref)
 
-copyNewFastString :: Int -> Ptr Word8 -> Int -> IO FastString
-copyNewFastString uid ptr len = do
+copyNewFastString :: Ptr Word8 -> Int -> Int -> IO FastString
+copyNewFastString ptr len uid = do
   fp <- copyBytesToForeignPtr ptr len
   ref <- newIORef Nothing
   n_chars <- countUTF8Chars ptr len
@@ -390,10 +457,10 @@ hashStr  :: Ptr Word8 -> Int -> Int
  -- use the Addr to produce a hash value between 0 & m (inclusive)
 hashStr (Ptr a#) (I# len#) = loop 0# 0#
    where
-    loop h n | n GHC.Exts.==# len# = I# h
-             | otherwise  = loop h2 (n GHC.Exts.+# 1#)
+    loop h n | n ExtsCompat46.==# len# = I# h
+             | otherwise  = loop h2 (n ExtsCompat46.+# 1#)
           where !c = ord# (indexCharOffAddr# a# n)
-                !h2 = (c GHC.Exts.+# (h GHC.Exts.*# 128#)) `remInt#`
+                !h2 = (c ExtsCompat46.+# (h ExtsCompat46.*# 128#)) `remInt#`
                       hASH_TBL_SIZE#
 
 -- -----------------------------------------------------------------------------
@@ -437,9 +504,10 @@ zEncodeFS fs@(FastString _ _ _ ref) =
         case m of
           Just zfs -> return zfs
           Nothing -> do
-            let zfs = mkZFastString (zEncodeString (unpackFS fs))
-            writeIORef ref (Just zfs)
-            return zfs
+            atomicModifyIORef ref $ \m' -> case m' of
+              Nothing  -> let zfs = mkZFastString (zEncodeString (unpackFS fs))
+                          in (Just zfs, zfs)
+              Just zfs -> (m', zfs)
 
 appendFS :: FastString -> FastString -> FastString
 appendFS fs1 fs2 = inlinePerformIO
@@ -478,8 +546,9 @@ nilFS = mkFastString ""
 
 getFastStringTable :: IO [[FastString]]
 getFastStringTable = do
-  tbl <- readIORef string_table
-  buckets <- mapM (lookupTbl tbl) [0 .. hASH_TBL_SIZE]
+  buckets <- forM [0.. hASH_TBL_SIZE-1] $ \idx -> do
+    bucket <- lookupTbl string_table idx
+    readIORef bucket
   return buckets
 
 -- -----------------------------------------------------------------------------
diff --git a/compiler/utils/FastTypes.lhs b/compiler/utils/FastTypes.lhs
index ace46e6e1b..0ef10ade56 100644
--- a/compiler/utils/FastTypes.lhs
+++ b/compiler/utils/FastTypes.lhs
@@ -14,10 +14,10 @@
 module FastTypes (
     -- * FastInt
     FastInt,
-    
+
     -- ** Getting in and out of FastInt
     _ILIT, iBox, iUnbox,
-    
+
     -- ** Arithmetic on FastInt
     (+#), (-#), (*#), quotFastInt, negateFastInt,
     --quotRemFastInt is difficult because unboxed values can't
@@ -51,11 +51,11 @@ module FastTypes (
     --character values above the range of Unicode
 
     -- * FastPtr
-    FastPtr, 
-    
+    FastPtr,
+
     -- ** Getting in and out of FastPtr
     pBox, pUnbox,
-    
+
     -- ** Casting FastPtrs
     castFastPtr
   ) where
@@ -65,7 +65,7 @@ module FastTypes (
 #if defined(__GLASGOW_HASKELL__)
 
 -- Import the beggars
-import GHC.Exts
+import ExtsCompat46
 
 type FastInt = Int#
 
diff --git a/compiler/utils/Fingerprint.hsc b/compiler/utils/Fingerprint.hsc
index 95f31c08bb..9a55e385b3 100644
--- a/compiler/utils/Fingerprint.hsc
+++ b/compiler/utils/Fingerprint.hsc
@@ -1,25 +1,33 @@
 -- ----------------------------------------------------------------------------
--- 
+--
 --  (c) The University of Glasgow 2006
 --
 -- Fingerprints for recompilation checking and ABI versioning.
 --
--- http://hackage.haskell.org/trac/ghc/wiki/Commentary/Compiler/RecompilationAvoidance
+-- http://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/RecompilationAvoidance
 --
 -- ----------------------------------------------------------------------------
 
-{-# OPTIONS_GHC -fno-warn-orphans #-}
 module Fingerprint (
         Fingerprint(..), fingerprint0,
         readHexFingerprint,
         fingerprintData,
-        fingerprintString
+        fingerprintString,
+        -- Re-exported from GHC.Fingerprint for GHC >= 7.7, local otherwise
+        getFileHash
    ) where
 
 #include "md5.h"
 ##include "HsVersions.h"
 
 import Numeric          ( readHex )
+#if __GLASGOW_HASKELL__ < 707
+-- Only needed for getFileHash below.
+import Foreign
+import Panic
+import System.IO
+import Control.Monad    ( when )
+#endif
 
 import GHC.Fingerprint
 
@@ -30,3 +38,32 @@ readHexFingerprint s = Fingerprint w1 w2
        [(w1,"")] = readHex s1
        [(w2,"")] = readHex (take 16 s2)
 
+
+#if __GLASGOW_HASKELL__ < 707
+-- Only use this if we're smaller than GHC 7.7, otherwise
+-- GHC.Fingerprint exports a better version of this function.
+
+-- | Computes the hash of a given file.
+-- It loads the full file into memory an does not work with files bigger than
+-- MAXINT.
+getFileHash :: FilePath -> IO Fingerprint
+getFileHash path = withBinaryFile path ReadMode $ \h -> do
+
+  fileSize <- toIntFileSize `fmap` hFileSize h
+
+  allocaBytes fileSize $ \bufPtr -> do
+    n <- hGetBuf h bufPtr fileSize
+    when (n /= fileSize) readFailedError
+    fingerprintData bufPtr fileSize
+
+  where
+    toIntFileSize :: Integer -> Int
+    toIntFileSize size
+      | size > fromIntegral (maxBound :: Int) = throwGhcException $
+          Sorry $ "Fingerprint.getFileHash: Tried to calculate hash of file "
+                  ++ path ++ " with size > maxBound :: Int. This is not supported."
+      | otherwise = fromIntegral size
+
+    readFailedError = throwGhcException $
+        Panic $ "Fingerprint.getFileHash: hGetBuf failed on interface file"
+#endif
diff --git a/compiler/utils/FiniteMap.lhs b/compiler/utils/FiniteMap.lhs
index 94d1eef94e..b52f28c324 100644
--- a/compiler/utils/FiniteMap.lhs
+++ b/compiler/utils/FiniteMap.lhs
@@ -27,10 +27,6 @@ deleteList ks m = foldl (flip Map.delete) m ks
 foldRight        :: (elt -> a -> a) -> a -> Map key elt -> a
 foldRight        = Map.fold
 foldRightWithKey :: (key -> elt -> a -> a) -> a -> Map key elt -> a
-#if (MIN_VERSION_containers(0,4,0))
 foldRightWithKey = Map.foldrWithKey
-#else
-foldRightWithKey = Map.foldWithKey
-#endif
 \end{code}
 
diff --git a/compiler/utils/GraphBase.hs b/compiler/utils/GraphBase.hs
index c070df4762..8cb3acee71 100644
--- a/compiler/utils/GraphBase.hs
+++ b/compiler/utils/GraphBase.hs
@@ -5,7 +5,7 @@
 -- The above warning supression flag is a temporary kludge.
 -- While working on this module you are encouraged to remove it and
 -- detab the module (please do the detabbing in a separate patch). See
---     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
+--     http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
 -- for details
 
 module GraphBase (
diff --git a/compiler/utils/GraphPpr.hs b/compiler/utils/GraphPpr.hs
index 5ea5fdfb75..a896bbbf63 100644
--- a/compiler/utils/GraphPpr.hs
+++ b/compiler/utils/GraphPpr.hs
@@ -5,7 +5,7 @@
 -- The above warning supression flag is a temporary kludge.
 -- While working on this module you are encouraged to remove it and
 -- detab the module (please do the detabbing in a separate patch). See
---     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
+--     http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
 -- for details
 
 module GraphPpr (
diff --git a/compiler/utils/IOEnv.hs b/compiler/utils/IOEnv.hs
index 583e875903..6885bbd127 100644
--- a/compiler/utils/IOEnv.hs
+++ b/compiler/utils/IOEnv.hs
@@ -22,7 +22,7 @@ module IOEnv (
         -- Getting at the environment
         getEnv, setEnv, updEnv,
 
-        runIOEnv, unsafeInterleaveM,
+        runIOEnv, unsafeInterleaveM, uninterruptibleMaskM_,
         tryM, tryAllM, tryMostM, fixM,
 
         -- I/O operations
@@ -42,6 +42,7 @@ import System.IO.Unsafe ( unsafeInterleaveIO )
 import System.IO        ( fixIO )
 import Control.Monad
 import MonadUtils
+import Control.Applicative (Alternative(..))
 
 ----------------------------------------------------------------------
 -- Defining the monad type
@@ -148,11 +149,17 @@ tryMostM (IOEnv thing) = IOEnv (\ env -> tryMost (thing env))
 unsafeInterleaveM :: IOEnv env a -> IOEnv env a
 unsafeInterleaveM (IOEnv m) = IOEnv (\ env -> unsafeInterleaveIO (m env))
 
+uninterruptibleMaskM_ :: IOEnv env a -> IOEnv env a
+uninterruptibleMaskM_ (IOEnv m) = IOEnv (\ env -> uninterruptibleMask_ (m env))
 
 ----------------------------------------------------------------------
--- MonadPlus
+-- Alternative/MonadPlus
 ----------------------------------------------------------------------
 
+instance MonadPlus IO => Alternative (IOEnv env) where
+      empty = mzero
+      (<|>) = mplus
+
 -- For use if the user has imported Control.Monad.Error from MTL
 -- Requires UndecidableInstances
 instance MonadPlus IO => MonadPlus (IOEnv env) where
diff --git a/compiler/utils/Maybes.lhs b/compiler/utils/Maybes.lhs
index 210a7b9f02..d9e1762a2f 100644
--- a/compiler/utils/Maybes.lhs
+++ b/compiler/utils/Maybes.lhs
@@ -4,13 +4,6 @@
 %
 
 \begin{code}
-{-# OPTIONS -fno-warn-tabs #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and
--- detab the module (please do the detabbing in a separate patch). See
---     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
--- for details
-
 module Maybes (
         module Data.Maybe,
 
@@ -18,15 +11,14 @@ module Maybes (
         failME, isSuccess,
 
         orElse,
-        mapCatMaybes,
-        allMaybes,
         firstJust, firstJusts,
+        whenIsJust,
         expectJust,
-        maybeToBool,
 
         MaybeT(..)
     ) where
-
+import Control.Applicative
+import Control.Monad
 import Data.Maybe
 
 infixr 4 `orElse`
@@ -39,55 +31,32 @@ infixr 4 `orElse`
 %************************************************************************
 
 \begin{code}
-maybeToBool :: Maybe a -> Bool
-maybeToBool Nothing  = False
-maybeToBool (Just _) = True
-
--- | Collects a list of @Justs@ into a single @Just@, returning @Nothing@ if
--- there are any @Nothings@.
-allMaybes :: [Maybe a] -> Maybe [a]
-allMaybes [] = Just []
-allMaybes (Nothing : _)  = Nothing
-allMaybes (Just x  : ms) = case allMaybes ms of
-                           Nothing -> Nothing
-                           Just xs -> Just (x:xs)
-
 firstJust :: Maybe a -> Maybe a -> Maybe a
-firstJust (Just a) _ = Just a
-firstJust Nothing  b = b
+firstJust a b = firstJusts [a, b]
 
 -- | Takes a list of @Maybes@ and returns the first @Just@ if there is one, or
 -- @Nothing@ otherwise.
 firstJusts :: [Maybe a] -> Maybe a
-firstJusts = foldr firstJust Nothing
-\end{code}
+firstJusts = msum
 
-\begin{code}
 expectJust :: String -> Maybe a -> a
 {-# INLINE expectJust #-}
 expectJust _   (Just x) = x
 expectJust err Nothing  = error ("expectJust " ++ err)
-\end{code}
 
-\begin{code}
-mapCatMaybes :: (a -> Maybe b) -> [a] -> [b]
-mapCatMaybes _ [] = []
-mapCatMaybes f (x:xs) = case f x of
-                        Just y  -> y : mapCatMaybes f xs
-                        Nothing -> mapCatMaybes f xs
-\end{code}
+whenIsJust :: Monad m => Maybe a -> (a -> m ()) -> m ()
+whenIsJust (Just x) f = f x
+whenIsJust Nothing  _ = return ()
 
-\begin{code}
--- | flipped version of @fromMaybe@.
+-- | Flipped version of @fromMaybe@, useful for chaining.
 orElse :: Maybe a -> a -> a
-(Just x) `orElse` _ = x
-Nothing  `orElse` y = y
+orElse = flip fromMaybe
 \end{code}
 
 %************************************************************************
-%*									*
+%*                                                                      *
 \subsection[MaybeT type]{The @MaybeT@ monad transformer}
-%*									*
+%*                                                                      *
 %************************************************************************
 
 \begin{code}
@@ -97,6 +66,10 @@ newtype MaybeT m a = MaybeT {runMaybeT :: m (Maybe a)}
 instance Functor m => Functor (MaybeT m) where
   fmap f x = MaybeT $ fmap (fmap f) $ runMaybeT x
 
+instance (Monad m, Functor m) => Applicative (MaybeT m) where
+  pure  = return
+  (<*>) = ap
+
 instance Monad m => Monad (MaybeT m) where
   return = MaybeT . return . Just
   x >>= f = MaybeT $ runMaybeT x >>= maybe (return Nothing) (runMaybeT . f)
@@ -114,6 +87,13 @@ instance Monad m => Monad (MaybeT m) where
 \begin{code}
 data MaybeErr err val = Succeeded val | Failed err
 
+instance Functor (MaybeErr err) where
+  fmap = liftM
+
+instance Applicative (MaybeErr err) where
+  pure  = return
+  (<*>) = ap
+
 instance Monad (MaybeErr err) where
   return v = Succeeded v
   Succeeded v >>= k = k v
diff --git a/compiler/utils/OrdList.lhs b/compiler/utils/OrdList.lhs
index 7e3b24a5da..d1d8708dd3 100644
--- a/compiler/utils/OrdList.lhs
+++ b/compiler/utils/OrdList.lhs
@@ -9,15 +9,8 @@ Provide trees (of instructions), so that lists of instructions
 can be appended in linear time.
 
 \begin{code}
-{-# OPTIONS -fno-warn-tabs #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and
--- detab the module (please do the detabbing in a separate patch). See
---     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
--- for details
-
 module OrdList (
-	OrdList, 
+        OrdList,
         nilOL, isNilOL, unitOL, appOL, consOL, snocOL, concatOL,
         mapOL, fromOL, toOL, foldrOL, foldlOL
 ) where
diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs
index bd2a955469..e8d9347767 100644
--- a/compiler/utils/Outputable.lhs
+++ b/compiler/utils/Outputable.lhs
@@ -32,7 +32,7 @@ module Outputable (
         sep, cat,
         fsep, fcat,
         hang, punctuate, ppWhen, ppUnless,
-        speakNth, speakNTimes, speakN, speakNOf, plural,
+        speakNth, speakNTimes, speakN, speakNOf, plural, isOrAre,
 
         coloured, PprColour, colType, colCoerc, colDataCon,
         colBinder, bold, keyword,
@@ -42,8 +42,7 @@ module Outputable (
         pprCode, mkCodeStyle,
         showSDoc, showSDocOneLine,
         showSDocForUser, showSDocDebug, showSDocDump, showSDocDumpOneLine,
-        showPpr,
-        showSDocUnqual,
+        showSDocUnqual, showPpr,
         renderWithStyle,
 
         pprInfixVar, pprPrefixVar,
@@ -53,7 +52,9 @@ module Outputable (
         -- * Controlling the style in which output is printed
         BindingSite(..),
 
-        PprStyle, CodeStyle(..), PrintUnqualified, alwaysQualify, neverQualify,
+        PprStyle, CodeStyle(..), PrintUnqualified,
+        alwaysQualify, alwaysQualifyNames, alwaysQualifyModules,
+        neverQualify, neverQualifyNames, neverQualifyModules,
         QualifyName(..),
         sdocWithDynFlags, sdocWithPlatform,
         getPprStyle, withPprStyle, withPprStyleDoc,
@@ -75,7 +76,7 @@ import {-# SOURCE #-}   DynFlags( DynFlags,
                                   useUnicodeQuotes,
                                   unsafeGlobalDynFlags )
 import {-# SOURCE #-}   Module( Module, ModuleName, moduleName )
-import {-# SOURCE #-}   Name( Name, nameModule )
+import {-# SOURCE #-}   OccName( OccName )
 import {-# SOURCE #-}   StaticFlags( opt_PprStyle_Debug, opt_NoDebugOutput )
 
 import FastString
@@ -90,6 +91,7 @@ import Data.ByteString (ByteString)
 import qualified Data.ByteString as BS
 import Data.Char
 import qualified Data.Map as M
+import Data.Int
 import qualified Data.IntMap as IM
 import Data.Set (Set)
 import qualified Data.Set as Set
@@ -144,13 +146,20 @@ data Depth = AllTheWay
 -- purpose of the pair of functions that gets passed around
 -- when rendering 'SDoc'.
 
+type PrintUnqualified = (QueryQualifyName, QueryQualifyModule)
+
 -- | given an /original/ name, this function tells you which module
 -- name it should be qualified with when printing for the user, if
 -- any.  For example, given @Control.Exception.catch@, which is in scope
 -- as @Exception.catch@, this fuction will return @Just "Exception"@.
 -- Note that the return value is a ModuleName, not a Module, because
 -- in source code, names are qualified by ModuleNames.
-type QueryQualifyName = Name -> QualifyName
+type QueryQualifyName = Module -> OccName -> QualifyName
+
+-- | For a given module, we need to know whether to print it with
+-- a package name to disambiguate it.
+type QueryQualifyModule = Module -> Bool
+
 
 -- See Note [Printing original names] in HscTypes
 data QualifyName                        -- given P:M.T
@@ -163,18 +172,11 @@ data QualifyName                        -- given P:M.T
                 -- it is not in scope at all, and M.T is already bound in the
                 -- current scope, so we must refer to it as "P:M.T"
 
-
--- | For a given module, we need to know whether to print it with
--- a package name to disambiguate it.
-type QueryQualifyModule = Module -> Bool
-
-type PrintUnqualified = (QueryQualifyName, QueryQualifyModule)
-
 alwaysQualifyNames :: QueryQualifyName
-alwaysQualifyNames n = NameQual (moduleName (nameModule n))
+alwaysQualifyNames m _ = NameQual (moduleName m)
 
 neverQualifyNames :: QueryQualifyName
-neverQualifyNames _ = NameUnqual
+neverQualifyNames _ _ = NameUnqual
 
 alwaysQualifyModules :: QueryQualifyModule
 alwaysQualifyModules _ = True
@@ -295,8 +297,8 @@ sdocWithPlatform f = sdocWithDynFlags (f . targetPlatform)
 
 \begin{code}
 qualName :: PprStyle -> QueryQualifyName
-qualName (PprUser (qual_name,_) _)  n = qual_name n
-qualName _other                     n = NameQual (moduleName (nameModule n))
+qualName (PprUser (qual_name,_) _)  mod occ = qual_name mod occ
+qualName _other                     mod _   = NameQual (moduleName mod)
 
 qualModule :: PprStyle -> QueryQualifyModule
 qualModule (PprUser (_,qual_mod) _)  m = qual_mod m
@@ -363,44 +365,47 @@ mkCodeStyle = PprCode
 -- However, Doc *is* an instance of Show
 -- showSDoc just blasts it out as a string
 showSDoc :: DynFlags -> SDoc -> String
-showSDoc dflags d =
-  Pretty.showDocWith PageMode
-    (runSDoc d (initSDocContext dflags defaultUserStyle))
+showSDoc dflags sdoc = renderWithStyle dflags sdoc defaultUserStyle
 
 renderWithStyle :: DynFlags -> SDoc -> PprStyle -> String
-renderWithStyle dflags sdoc sty =
-  Pretty.render (runSDoc sdoc (initSDocContext dflags sty))
+renderWithStyle dflags sdoc sty
+  = Pretty.showDoc PageMode (pprCols dflags) $
+    runSDoc sdoc (initSDocContext dflags sty)
 
 -- This shows an SDoc, but on one line only. It's cheaper than a full
 -- showSDoc, designed for when we're getting results like "Foo.bar"
 -- and "foo{uniq strictness}" so we don't want fancy layout anyway.
 showSDocOneLine :: DynFlags -> SDoc -> String
 showSDocOneLine dflags d
- = Pretty.showDocWith PageMode
-    (runSDoc d (initSDocContext dflags defaultUserStyle))
+ = Pretty.showDoc OneLineMode (pprCols dflags) $
+   runSDoc d (initSDocContext dflags defaultUserStyle)
 
 showSDocForUser :: DynFlags -> PrintUnqualified -> SDoc -> String
 showSDocForUser dflags unqual doc
- = show (runSDoc doc (initSDocContext dflags (mkUserStyle unqual AllTheWay)))
+ = renderWithStyle dflags doc (mkUserStyle unqual AllTheWay)
 
 showSDocUnqual :: DynFlags -> SDoc -> String
--- Only used in the gruesome isOperator
-showSDocUnqual dflags d
- = show (runSDoc d (initSDocContext dflags (mkUserStyle neverQualify AllTheWay)))
+-- Only used by Haddock
+showSDocUnqual dflags doc
+ = renderWithStyle dflags doc (mkUserStyle neverQualify AllTheWay)
 
 showSDocDump :: DynFlags -> SDoc -> String
-showSDocDump dflags d
- = Pretty.showDocWith PageMode (runSDoc d (initSDocContext dflags defaultDumpStyle))
+showSDocDump dflags d = renderWithStyle dflags d defaultDumpStyle
+
+showSDocDebug :: DynFlags -> SDoc -> String
+showSDocDebug dflags d = renderWithStyle dflags d PprDebug
 
 showSDocDumpOneLine :: DynFlags -> SDoc -> String
 showSDocDumpOneLine dflags d
- = Pretty.showDocWith OneLineMode (runSDoc d (initSDocContext dflags PprDump))
-
-showSDocDebug :: DynFlags -> SDoc -> String
-showSDocDebug dflags d = show (runSDoc d (initSDocContext dflags PprDebug))
+ = Pretty.showDoc OneLineMode irrelevantNCols $
+   runSDoc d (initSDocContext dflags PprDump)
 
 showPpr :: Outputable a => DynFlags -> a -> String
-showPpr dflags = showSDoc dflags . ppr
+showPpr dflags thing = showSDoc dflags (ppr thing)
+
+irrelevantNCols :: Int
+-- Used for OneLineMode and LeftMode when number of cols isn't used
+irrelevantNCols = 1
 \end{code}
 
 \begin{code}
@@ -421,7 +426,10 @@ rational :: Rational   -> SDoc
 
 empty       = docToSDoc $ Pretty.empty
 char c      = docToSDoc $ Pretty.char c
+
 text s      = docToSDoc $ Pretty.text s
+{-# INLINE text #-}   -- Inline so that the RULE Pretty.text will fire
+
 ftext s     = docToSDoc $ Pretty.ftext s
 ptext s     = docToSDoc $ Pretty.ptext s
 ztext s     = docToSDoc $ Pretty.ztext s
@@ -452,7 +460,7 @@ cparen b d     = SDoc $ Pretty.cparen b . runSDoc d
 quotes d =
       sdocWithDynFlags $ \dflags ->
       if useUnicodeQuotes dflags
-      then char '‛' <> d <> char '’'
+      then char '‘' <> d <> char '’'
       else SDoc $ \sty ->
            let pp_d = runSDoc d sty
                str  = show pp_d
@@ -616,6 +624,12 @@ instance Outputable Bool where
     ppr True  = ptext (sLit "True")
     ppr False = ptext (sLit "False")
 
+instance Outputable Int32 where
+   ppr n = integer $ fromIntegral n
+
+instance Outputable Int64 where
+   ppr n = integer $ fromIntegral n
+
 instance Outputable Int where
     ppr n = int n
 
@@ -898,6 +912,15 @@ speakNTimes t | t == 1     = ptext (sLit "once")
 plural :: [a] -> SDoc
 plural [_] = empty  -- a bit frightening, but there you are
 plural _   = char 's'
+
+-- | Determines the form of to be appropriate for the length of a list:
+--
+-- > isOrAre [] = ptext (sLit "are")
+-- > isOrAre ["Hello"] = ptext (sLit "is")
+-- > isOrAre ["Hello", "World"] = ptext (sLit "are")
+isOrAre :: [a] -> SDoc
+isOrAre [_] = ptext (sLit "is")
+isOrAre _   = ptext (sLit "are")
 \end{code}
 
 
diff --git a/compiler/utils/Platform.hs b/compiler/utils/Platform.hs
index 213a63e0c8..ea1a3e5e93 100644
--- a/compiler/utils/Platform.hs
+++ b/compiler/utils/Platform.hs
@@ -12,7 +12,9 @@ module Platform (
         target32Bit,
         isARM,
         osElfTarget,
+        osMachOTarget,
         platformUsesFrameworks,
+        platformBinariesAreStaticLibs,
 )
 
 where
@@ -53,6 +55,7 @@ data Arch
         | ArchAlpha
         | ArchMipseb
         | ArchMipsel
+        | ArchJavaScript
         deriving (Read, Show, Eq)
 
 isARM :: Arch -> Bool
@@ -127,6 +130,11 @@ osElfTarget OSUnknown   = False
  -- portability, otherwise we have to answer this question for every
  -- new platform we compile on (even unreg).
 
+-- | This predicate tells us whether the OS support Mach-O shared libraries.
+osMachOTarget :: OS -> Bool
+osMachOTarget OSDarwin = True
+osMachOTarget _ = False
+
 osUsesFrameworks :: OS -> Bool
 osUsesFrameworks OSDarwin = True
 osUsesFrameworks OSiOS    = True
@@ -135,3 +143,10 @@ osUsesFrameworks _        = False
 platformUsesFrameworks :: Platform -> Bool
 platformUsesFrameworks = osUsesFrameworks . platformOS
 
+osBinariesAreStaticLibs :: OS -> Bool
+osBinariesAreStaticLibs OSiOS = True
+osBinariesAreStaticLibs _     = False
+
+platformBinariesAreStaticLibs :: Platform -> Bool
+platformBinariesAreStaticLibs = osBinariesAreStaticLibs . platformOS
+
diff --git a/compiler/utils/Pretty.lhs b/compiler/utils/Pretty.lhs
index e4f748a05d..fb7fe2b7fb 100644
--- a/compiler/utils/Pretty.lhs
+++ b/compiler/utils/Pretty.lhs
@@ -71,7 +71,7 @@ Version 2.0     24 April 1997
         nest k empty = empty
     which wasn't true before.
 
-  * Fixed an obscure bug in sep that occassionally gave very wierd behaviour
+  * Fixed an obscure bug in sep that occasionally gave very weird behaviour
 
   * Added $+$
 
@@ -173,8 +173,7 @@ module Pretty (
 
         hang, punctuate,
 
---      renderStyle,            -- Haskell 1.3 only
-        render, fullRender, printDoc, showDocWith,
+        fullRender, printDoc, printDoc_, showDoc,
         bufLeftRender -- performance hack
   ) where
 
@@ -270,9 +269,8 @@ Displaying @Doc@ values.
 
 \begin{code}
 instance Show Doc where
-  showsPrec _ doc cont = showDoc doc cont
+  showsPrec _ doc cont = showDocPlus PageMode 100 doc cont
 
-render     :: Doc -> String             -- Uses default style
 fullRender :: Mode
            -> Int                       -- Line length
            -> Float                     -- Ribbons per line
@@ -281,21 +279,10 @@ fullRender :: Mode
            -> Doc
            -> a                         -- Result
 
-{-      When we start using 1.3
-renderStyle  :: Style -> Doc -> String
-data Style = Style { lineLength     :: Int,     -- In chars
-                     ribbonsPerLine :: Float,   -- Ratio of ribbon length to line length
-                     mode :: Mode
-             }
-style :: Style          -- The default style
-style = Style { lineLength = 100, ribbonsPerLine = 2.5, mode = PageMode }
--}
-
 data Mode = PageMode            -- Normal
           | ZigZagMode          -- With zig-zag cuts
           | LeftMode            -- No indentation, infinitely long lines
           | OneLineMode         -- All on one line
-
 \end{code}
 
 
@@ -557,7 +544,9 @@ isEmpty _     = False
 char  c = textBeside_ (Chr c) (_ILIT(1)) Empty
 
 text  s = case iUnbox (length   s) of {sl -> textBeside_ (Str s)  sl Empty}
-{-# NOINLINE [1] text #-}   -- Give the RULE a chance to fire
+{-# NOINLINE [0] text #-}   -- Give the RULE a chance to fire
+                            -- It must wait till after phase 1 when
+                            -- the unpackCString first is manifested
 
 ftext :: FastString -> Doc
 ftext s = case iUnbox (lengthFS s) of {sl -> textBeside_ (PStr s) sl Empty}
@@ -888,21 +877,11 @@ oneLiner _                   = panic "oneLiner: Unhandled case"
 
 
 \begin{code}
-{-
-renderStyle Style{mode, lineLength, ribbonsPerLine} doc
-  = fullRender mode lineLength ribbonsPerLine doc ""
--}
-
-render doc       = showDocWith PageMode doc
-
-showDoc :: Doc -> String -> String
-showDoc doc rest = showDocWithAppend PageMode doc rest
-
-showDocWithAppend :: Mode -> Doc -> String -> String
-showDocWithAppend mode doc rest = fullRender mode 100 1.5 string_txt rest doc
+showDocPlus :: Mode -> Int -> Doc -> String -> String
+showDocPlus mode cols doc rest = fullRender mode cols 1.5 string_txt rest doc
 
-showDocWith :: Mode -> Doc -> String
-showDocWith mode doc = showDocWithAppend mode doc ""
+showDoc :: Mode -> Int -> Doc -> String
+showDoc mode cols doc = showDocPlus mode cols doc ""
 
 string_txt :: TextDetails -> String -> String
 string_txt (Chr c)   s  = c:s
@@ -1006,9 +985,16 @@ spaces n | n <=# _ILIT(0) = ""
 
 \begin{code}
 printDoc :: Mode -> Int -> Handle -> Doc -> IO ()
-printDoc LeftMode _ hdl doc
+-- printDoc adds a newline to the end
+printDoc mode cols hdl doc = printDoc_ mode cols hdl (doc $$ text "")
+
+printDoc_ :: Mode -> Int -> Handle -> Doc -> IO ()
+-- printDoc_ does not add a newline at the end, so that
+-- successive calls can output stuff on the same line
+-- Rather like putStr vs putStrLn
+printDoc_ LeftMode _ hdl doc
   = do { printLeftRender hdl doc; hFlush hdl }
-printDoc mode pprCols hdl doc
+printDoc_ mode pprCols hdl doc
   = do { fullRender mode pprCols 1.5 put done doc ;
          hFlush hdl }
   where
@@ -1020,7 +1006,7 @@ printDoc mode pprCols hdl doc
     put (ZStr s) next = hPutFZS  hdl s >> next
     put (LStr s l) next = hPutLitString hdl s l >> next
 
-    done = hPutChar hdl '\n'
+    done = return () -- hPutChar hdl '\n'
 
   -- some versions of hPutBuf will barf if the length is zero
 hPutLitString :: Handle -> Ptr a -> Int# -> IO ()
diff --git a/compiler/utils/Stream.hs b/compiler/utils/Stream.hs
index 2fa76d2345..47cdee0789 100644
--- a/compiler/utils/Stream.hs
+++ b/compiler/utils/Stream.hs
@@ -11,6 +11,8 @@ module Stream (
     collect, fromList,
     Stream.map, Stream.mapM, Stream.mapAccumL
   ) where
+import Control.Monad
+import Control.Applicative
 
 -- |
 -- @Stream m a b@ is a computation in some Monad @m@ that delivers a sequence
@@ -37,6 +39,13 @@ module Stream (
 --
 newtype Stream m a b = Stream { runStream :: m (Either b (a, Stream m a b)) }
 
+instance Monad f => Functor (Stream f a) where
+  fmap = liftM
+
+instance Monad m => Applicative (Stream m a) where
+  pure  = return
+  (<*>) = ap
+
 instance Monad m => Monad (Stream m a) where
   return a = Stream (return (Left a))
 
@@ -66,7 +75,7 @@ collect str = go str []
 fromList :: Monad m => [a] -> Stream m a ()
 fromList = mapM_ yield
 
--- | Apply a function to each element of a 'Stream', lazilly
+-- | Apply a function to each element of a 'Stream', lazily
 map :: Monad m => (a -> b) -> Stream m a x -> Stream m b x
 map f str = Stream $ do
    r <- runStream str
@@ -74,7 +83,7 @@ map f str = Stream $ do
      Left x -> return (Left x)
      Right (a, str') -> return (Right (f a, Stream.map f str'))
 
--- | Apply a monadic operation to each element of a 'Stream', lazilly
+-- | Apply a monadic operation to each element of a 'Stream', lazily
 mapM :: Monad m => (a -> m b) -> Stream m a x -> Stream m b x
 mapM f str = Stream $ do
    r <- runStream str
diff --git a/compiler/utils/UnVarGraph.hs b/compiler/utils/UnVarGraph.hs
new file mode 100644
index 0000000000..228f3b5220
--- /dev/null
+++ b/compiler/utils/UnVarGraph.hs
@@ -0,0 +1,136 @@
+{-
+
+Copyright (c) 2014 Joachim Breitner
+
+A data structure for undirected graphs of variables
+(or in plain terms: Sets of unordered pairs of numbers)
+
+
+This is very specifically tailored for the use in CallArity. In particular it
+stores the graph as a union of complete and complete bipartite graph, which
+would be very expensive to store as sets of edges or as adjanceny lists.
+
+It does not normalize the graphs. This means that g `unionUnVarGraph` g is
+equal to g, but twice as expensive and large.
+
+-}
+module UnVarGraph
+    ( UnVarSet
+    , emptyUnVarSet, mkUnVarSet, varEnvDom, unionUnVarSet, unionUnVarSets
+    , delUnVarSet
+    , elemUnVarSet, isEmptyUnVarSet
+    , UnVarGraph
+    , emptyUnVarGraph
+    , unionUnVarGraph, unionUnVarGraphs
+    , completeGraph, completeBipartiteGraph
+    , neighbors
+    , delNode
+    ) where
+
+import Id
+import VarEnv
+import UniqFM
+import Outputable
+import Data.List
+import Bag
+import Unique
+
+import qualified Data.IntSet as S
+
+-- We need a type for sets of variables (UnVarSet).
+-- We do not use VarSet, because for that we need to have the actual variable
+-- at hand, and we do not have that when we turn the domain of a VarEnv into a UnVarSet.
+-- Therefore, use a IntSet directly (which is likely also a bit more efficient).
+
+-- Set of uniques, i.e. for adjancet nodes
+newtype UnVarSet = UnVarSet (S.IntSet)
+    deriving Eq
+
+k :: Var -> Int
+k v = getKey (getUnique v)
+
+emptyUnVarSet :: UnVarSet
+emptyUnVarSet = UnVarSet S.empty
+
+elemUnVarSet :: Var -> UnVarSet -> Bool
+elemUnVarSet v (UnVarSet s) = k v `S.member` s
+
+
+isEmptyUnVarSet :: UnVarSet -> Bool
+isEmptyUnVarSet (UnVarSet s) = S.null s
+
+delUnVarSet :: UnVarSet -> Var -> UnVarSet
+delUnVarSet (UnVarSet s) v = UnVarSet $ k v `S.delete` s
+
+mkUnVarSet :: [Var] -> UnVarSet
+mkUnVarSet vs = UnVarSet $ S.fromList $ map k vs
+
+varEnvDom :: VarEnv a -> UnVarSet
+varEnvDom ae = UnVarSet $ ufmToSet_Directly ae
+
+unionUnVarSet :: UnVarSet -> UnVarSet -> UnVarSet
+unionUnVarSet (UnVarSet set1) (UnVarSet set2) = UnVarSet (set1 `S.union` set2)
+
+unionUnVarSets :: [UnVarSet] -> UnVarSet
+unionUnVarSets = foldr unionUnVarSet emptyUnVarSet
+
+instance Outputable UnVarSet where
+    ppr (UnVarSet s) = braces $
+        hcat $ punctuate comma [ ppr (getUnique i) | i <- S.toList s]
+
+
+-- The graph type. A list of complete bipartite graphs
+data Gen = CBPG UnVarSet UnVarSet -- complete bipartite
+         | CG   UnVarSet          -- complete
+newtype UnVarGraph = UnVarGraph (Bag Gen)
+
+emptyUnVarGraph :: UnVarGraph
+emptyUnVarGraph = UnVarGraph emptyBag
+
+unionUnVarGraph :: UnVarGraph -> UnVarGraph -> UnVarGraph
+{-
+Premature optimisation, it seems.
+unionUnVarGraph (UnVarGraph [CBPG s1 s2]) (UnVarGraph [CG s3, CG s4])
+    | s1 == s3 && s2 == s4
+    = pprTrace "unionUnVarGraph fired" empty $
+      completeGraph (s1 `unionUnVarSet` s2)
+unionUnVarGraph (UnVarGraph [CBPG s1 s2]) (UnVarGraph [CG s3, CG s4])
+    | s2 == s3 && s1 == s4
+    = pprTrace "unionUnVarGraph fired2" empty $
+      completeGraph (s1 `unionUnVarSet` s2)
+-}
+unionUnVarGraph (UnVarGraph g1) (UnVarGraph g2)
+    = -- pprTrace "unionUnVarGraph" (ppr (length g1, length g2)) $
+      UnVarGraph (g1 `unionBags` g2)
+
+unionUnVarGraphs :: [UnVarGraph] -> UnVarGraph
+unionUnVarGraphs = foldl' unionUnVarGraph emptyUnVarGraph
+
+-- completeBipartiteGraph A B = { {a,b} | a ∈ A, b ∈ B }
+completeBipartiteGraph :: UnVarSet -> UnVarSet -> UnVarGraph
+completeBipartiteGraph s1 s2 = prune $ UnVarGraph $ unitBag $ CBPG s1 s2
+
+completeGraph :: UnVarSet -> UnVarGraph
+completeGraph s = prune $ UnVarGraph $ unitBag $ CG s
+
+neighbors :: UnVarGraph -> Var -> UnVarSet
+neighbors (UnVarGraph g) v = unionUnVarSets $ concatMap go $ bagToList g
+  where go (CG s)       = (if v `elemUnVarSet` s then [s] else [])
+        go (CBPG s1 s2) = (if v `elemUnVarSet` s1 then [s2] else []) ++
+                          (if v `elemUnVarSet` s2 then [s1] else [])
+
+delNode :: UnVarGraph -> Var -> UnVarGraph
+delNode (UnVarGraph g) v = prune $ UnVarGraph $ mapBag go g
+  where go (CG s)       = CG (s `delUnVarSet` v)
+        go (CBPG s1 s2) = CBPG (s1 `delUnVarSet` v) (s2 `delUnVarSet` v)
+
+prune :: UnVarGraph -> UnVarGraph
+prune (UnVarGraph g) = UnVarGraph $ filterBag go g
+  where go (CG s)       = not (isEmptyUnVarSet s)
+        go (CBPG s1 s2) = not (isEmptyUnVarSet s1) && not (isEmptyUnVarSet s2)
+
+instance Outputable Gen where
+    ppr (CG s)       = ppr s  <> char '²'
+    ppr (CBPG s1 s2) = ppr s1 <+> char 'x' <+> ppr s2
+instance Outputable UnVarGraph where
+    ppr (UnVarGraph g) = ppr g
diff --git a/compiler/utils/UniqFM.lhs b/compiler/utils/UniqFM.lhs
index ab39bc87f5..0836e12e28 100644
--- a/compiler/utils/UniqFM.lhs
+++ b/compiler/utils/UniqFM.lhs
@@ -20,7 +20,7 @@ and ``addToUFM\_C'' and ``Data.IntMap.insertWith'' differ in the order
 of arguments of combining function.
 
 \begin{code}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE DeriveTraversable, GeneralizedNewtypeDeriving #-}
 
 {-# OPTIONS -Wall #-}
 module UniqFM (
@@ -45,6 +45,7 @@ module UniqFM (
         delListFromUFM,
         plusUFM,
         plusUFM_C,
+        plusUFM_CD,
         minusUFM,
         intersectUFM,
         intersectUFM_C,
@@ -58,6 +59,7 @@ module UniqFM (
         lookupUFM, lookupUFM_Directly,
         lookupWithDefaultUFM, lookupWithDefaultUFM_Directly,
         eltsUFM, keysUFM, splitUFM,
+        ufmToSet_Directly,
         ufmToList,
         joinUFM
     ) where
@@ -69,10 +71,12 @@ import Compiler.Hoopl   hiding (Unique)
 
 import Data.Function (on)
 import qualified Data.IntMap as M
+import qualified Data.IntSet as S
 import qualified Data.Foldable as Foldable
 import qualified Data.Traversable as Traversable
 import Data.Typeable
 import Data.Data
+import Data.Monoid
 \end{code}
 
 %************************************************************************
@@ -135,6 +139,20 @@ plusUFM         :: UniqFM elt -> UniqFM elt -> UniqFM elt
 plusUFM_C       :: (elt -> elt -> elt)
                 -> UniqFM elt -> UniqFM elt -> UniqFM elt
 
+-- | `plusUFM_CD f m1 d1 m2 d2` merges the maps using `f` as the
+-- combinding function and `d1` resp. `d2` as the default value if
+-- there is no entry in `m1` reps. `m2`. The domain is the union of
+-- the domains of `m1` and `m2`.
+--
+-- Representative example:
+--
+-- @
+-- plusUFM_CD f {A: 1, B: 2} 23 {B: 3, C: 4} 42
+--    == {A: f 1 42, B: f 2 3, C: f 23 4 }
+-- @
+plusUFM_CD      :: (elt -> elt -> elt)
+                -> UniqFM elt -> elt -> UniqFM elt -> elt -> UniqFM elt
+
 minusUFM        :: UniqFM elt1 -> UniqFM elt2 -> UniqFM elt1
 
 intersectUFM    :: UniqFM elt -> UniqFM elt -> UniqFM elt
@@ -166,12 +184,25 @@ lookupWithDefaultUFM_Directly
                 :: UniqFM elt -> elt -> Unique -> elt
 keysUFM         :: UniqFM elt -> [Unique]       -- Get the keys
 eltsUFM         :: UniqFM elt -> [elt]
+ufmToSet_Directly :: UniqFM elt -> S.IntSet
 ufmToList       :: UniqFM elt -> [(Unique, elt)]
 
 \end{code}
 
 %************************************************************************
 %*                                                                      *
+\subsection{Monoid interface}
+%*                                                                      *
+%************************************************************************
+
+\begin{code}
+instance Monoid (UniqFM a) where
+    mempty = emptyUFM
+    mappend = plusUFM
+\end{code}
+
+%************************************************************************
+%*                                                                      *
 \subsection{Implementation using ``Data.IntMap''}
 %*                                                                      *
 %************************************************************************
@@ -224,7 +255,24 @@ delFromUFM_Directly (UFM m) u = UFM (M.delete (getKey u) m)
 
 -- M.union is left-biased, plusUFM should be right-biased.
 plusUFM (UFM x) (UFM y) = UFM (M.union y x)
+     -- Note (M.union y x), with arguments flipped
+     -- M.union is left-biased, plusUFM should be right-biased.
+
 plusUFM_C f (UFM x) (UFM y) = UFM (M.unionWith f x y)
+
+plusUFM_CD f (UFM xm) dx (UFM ym) dy
+{-
+The following implementation should be used as soon as we can expect
+containers-0.5; presumably from GHC 7.9 on:
+    = UFM $ M.mergeWithKey
+        (\_ x y -> Just (x `f` y))
+        (M.map (\x -> x `f` dy))
+        (M.map (\y -> dx `f` y))
+        xm ym
+-}
+    = UFM $ M.intersectionWith f xm ym
+        `M.union` M.map (\x -> x  `f` dy) xm
+        `M.union` M.map (\y -> dx `f`  y) ym
 minusUFM (UFM x) (UFM y) = UFM (M.difference x y)
 intersectUFM (UFM x) (UFM y) = UFM (M.intersection x y)
 intersectUFM_C f (UFM x) (UFM y) = UFM (M.intersectionWith f x y)
@@ -251,6 +299,7 @@ lookupWithDefaultUFM (UFM m) v k = M.findWithDefault v (getKey $ getUnique k) m
 lookupWithDefaultUFM_Directly (UFM m) v u = M.findWithDefault v (getKey u) m
 keysUFM (UFM m) = map getUnique $ M.keys m
 eltsUFM (UFM m) = M.elems m
+ufmToSet_Directly (UFM m) = M.keysSet m
 ufmToList (UFM m) = map (\(k, v) -> (getUnique k, v)) $ M.toList m
 
 -- Hoopl
diff --git a/compiler/utils/UniqSet.lhs b/compiler/utils/UniqSet.lhs
index f8e7d9039f..fae5ddabb6 100644
--- a/compiler/utils/UniqSet.lhs
+++ b/compiler/utils/UniqSet.lhs
@@ -9,13 +9,6 @@ Based on @UniqFMs@ (as you would expect).
 Basically, the things need to be in class @Uniquable@.
 
 \begin{code}
-{-# OPTIONS -fno-warn-tabs #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and
--- detab the module (please do the detabbing in a separate patch). See
---     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
--- for details
-
 module UniqSet (
         -- * Unique set type
         UniqSet,    -- type synonym for UniqFM a
@@ -38,6 +31,7 @@ module UniqSet (
         isEmptyUniqSet,
         lookupUniqSet,
         uniqSetToList,
+        partitionUniqSet
     ) where
 
 import UniqFM
@@ -46,9 +40,9 @@ import Unique
 \end{code}
 
 %************************************************************************
-%*									*
+%*                                                                      *
 \subsection{The signature of the module}
-%*									*
+%*                                                                      *
 %************************************************************************
 
 \begin{code}
@@ -74,12 +68,14 @@ mapUniqSet :: (a -> b) -> UniqSet a -> UniqSet b
 elementOfUniqSet :: Uniquable a => a -> UniqSet a -> Bool
 elemUniqSet_Directly :: Unique -> UniqSet a -> Bool
 filterUniqSet :: (a -> Bool) -> UniqSet a -> UniqSet a
+partitionUniqSet :: (a -> Bool) -> UniqSet a -> (UniqSet a, UniqSet a)
 
 sizeUniqSet :: UniqSet a -> Int
 isEmptyUniqSet :: UniqSet a -> Bool
 lookupUniqSet :: Uniquable a => UniqSet a -> a -> Maybe a
 uniqSetToList :: UniqSet a -> [a]
 \end{code}
+
 %************************************************************************
 %*                                                                      *
 \subsection{Implementation using ``UniqFM''}
@@ -113,6 +109,7 @@ mapUniqSet = mapUFM
 elementOfUniqSet = elemUFM
 elemUniqSet_Directly = elemUFM_Directly
 filterUniqSet = filterUFM
+partitionUniqSet = partitionUFM
 
 sizeUniqSet = sizeUFM
 isEmptyUniqSet = isNullUFM
diff --git a/compiler/utils/Util.lhs b/compiler/utils/Util.lhs
index 90a2077c71..5c82c757aa 100644
--- a/compiler/utils/Util.lhs
+++ b/compiler/utils/Util.lhs
@@ -14,11 +14,11 @@ module Util (
 
         -- * General list processing
         zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal,
-        zipLazy, stretchZipWith,
+        zipLazy, stretchZipWith, zipWithAndUnzip,
 
         unzipWith,
 
-        mapFst, mapSnd,
+        mapFst, mapSnd, chkAppend,
         mapAndUnzip, mapAndUnzip3, mapAccumL2,
         nOfThem, filterOut, partitionWith, splitEithers,
 
@@ -259,6 +259,13 @@ splitEithers (e : es) = case e of
                         Left x -> (x:xs, ys)
                         Right y -> (xs, y:ys)
     where (xs,ys) = splitEithers es
+
+chkAppend :: [a] -> [a] -> [a]
+-- Checks for the second arguemnt being empty
+-- Used in situations where that situation is common
+chkAppend xs ys 
+  | null ys   = xs
+  | otherwise = xs ++ ys
 \end{code}
 
 A paranoid @zip@ (and some @zipWith@ friends) that checks the lists
@@ -344,6 +351,14 @@ mapAndUnzip3 f (x:xs)
     in
     (r1:rs1, r2:rs2, r3:rs3)
 
+zipWithAndUnzip :: (a -> b -> (c,d)) -> [a] -> [b] -> ([c],[d])
+zipWithAndUnzip f (a:as) (b:bs)
+  = let (r1,  r2)  = f a b
+        (rs1, rs2) = zipWithAndUnzip f as bs
+    in
+    (r1:rs1, r2:rs2)
+zipWithAndUnzip _ _ _ = ([],[])
+
 mapAccumL2 :: (s1 -> s2 -> a -> (s1, s2, b)) -> s1 -> s2 -> [a] -> (s1, s2, [b])
 mapAccumL2 f s1 s2 xs = (s1', s2', ys)
   where ((s1', s2'), ys) = mapAccumL (\(s1, s2) x -> case f s1 s2 x of
@@ -559,7 +574,15 @@ splitAtList (_:xs) (y:ys) = (y:ys', ys'')
 
 -- drop from the end of a list
 dropTail :: Int -> [a] -> [a]
-dropTail n = reverse . drop n . reverse
+-- Specification: dropTail n = reverse . drop n . reverse
+-- Better implemention due to Joachim Breitner
+-- http://www.joachim-breitner.de/blog/archives/600-On-taking-the-last-n-elements-of-a-list.html
+dropTail n xs
+  = go (drop n xs) xs
+  where
+    go (_:ys) (x:xs) = x : go ys xs 
+    go _      _      = []  -- Stop when ys runs out
+                           -- It'll always run out before xs does
 
 snocView :: [a] -> Maybe ([a],a)
         -- Split off the last element
@@ -1088,7 +1111,7 @@ charToC w =
 hashString :: String -> Int32
 hashString = foldl' f golden
    where f m c = fromIntegral (ord c) * magic + hashInt32 m
-         magic = 0xdeadbeef
+         magic = fromIntegral (0xdeadbeef :: Word32)
 
 golden :: Int32
 golden = 1013904242 -- = round ((sqrt 5 - 1) * 2^32) :: Int32