diff --git a/compiler/cmm/CmmBuildInfoTables.hs b/compiler/cmm/CmmBuildInfoTables.hs
--- a/compiler/cmm/CmmBuildInfoTables.hs
+++ b/compiler/cmm/CmmBuildInfoTables.hs
@@ -19,7 +19,6 @@
 import GHC.Platform
 import Digraph
 import CLabel
-import PprCmmDecl ()
 import Cmm
 import CmmUtils
 import DynFlags
@@ -30,7 +29,6 @@
 import CostCentre
 import StgCmmHeap
 
-import PprCmm()
 import Control.Monad
 import Data.Map (Map)
 import qualified Data.Map as Map
@@ -729,7 +727,7 @@
     -- important that we don't do this for static functions or CAFs,
     -- see Note [Invalid optimisation: shortcutting].
     updateSRTMap srtEntry =
-      when (not isCAF && not isStaticFun) $ do
+      when (not isCAF && (not isStaticFun || isNothing srtEntry)) $ do
         let newSRTMap = Map.fromList [(cafLbl, srtEntry) | cafLbl <- lbls]
         put (Map.union newSRTMap srtMap)
 
diff --git a/compiler/cmm/CmmCallConv.hs b/compiler/cmm/CmmCallConv.hs
--- a/compiler/cmm/CmmCallConv.hs
+++ b/compiler/cmm/CmmCallConv.hs
@@ -10,7 +10,7 @@
 import CmmExpr
 import SMRep
 import Cmm (Convention(..))
-import PprCmm ()
+import PprCmm () -- For Outputable instances
 
 import DynFlags
 import GHC.Platform
diff --git a/compiler/cmm/CmmCommonBlockElim.hs b/compiler/cmm/CmmCommonBlockElim.hs
--- a/compiler/cmm/CmmCommonBlockElim.hs
+++ b/compiler/cmm/CmmCommonBlockElim.hs
@@ -13,7 +13,6 @@
 import CmmUtils
 import CmmSwitch (eqSwitchTargetWith)
 import CmmContFlowOpt
--- import PprCmm ()
 
 import Hoopl.Block
 import Hoopl.Graph
diff --git a/compiler/cmm/CmmInfo.hs b/compiler/cmm/CmmInfo.hs
--- a/compiler/cmm/CmmInfo.hs
+++ b/compiler/cmm/CmmInfo.hs
@@ -67,16 +67,17 @@
                  , cit_srt  = Nothing
                  , cit_clo  = Nothing }
 
-cmmToRawCmm :: DynFlags -> Stream IO CmmGroup ()
-            -> IO (Stream IO RawCmmGroup ())
+cmmToRawCmm :: DynFlags -> Stream IO CmmGroup a
+            -> IO (Stream IO RawCmmGroup a)
 cmmToRawCmm dflags cmms
   = do { uniqs <- mkSplitUniqSupply 'i'
-       ; let do_one uniqs cmm =
+       ; let do_one :: UniqSupply -> [CmmDecl] -> IO (UniqSupply, [RawCmmDecl])
+             do_one uniqs cmm =
                -- NB. strictness fixes a space leak.  DO NOT REMOVE.
                withTiming (return dflags) (text "Cmm -> Raw Cmm") forceRes $
                  case initUs uniqs $ concatMapM (mkInfoTable dflags) cmm of
                    (b,uniqs') -> return (uniqs',b)
-       ; return (Stream.mapAccumL do_one uniqs cmms >> return ())
+       ; return (snd <$> Stream.mapAccumL_ do_one uniqs cmms)
        }
 
     where forceRes (uniqs, rawcmms) =
@@ -577,7 +578,7 @@
 stdSrtBitmapOffset :: DynFlags -> ByteOff
 -- Byte offset of the SRT bitmap half-word which is
 -- in the *higher-addressed* part of the type_lit
-stdSrtBitmapOffset dflags = stdInfoTableSizeB dflags - hALF_WORD_SIZE dflags
+stdSrtBitmapOffset dflags = stdInfoTableSizeB dflags - halfWordSize dflags
 
 stdClosureTypeOffset :: DynFlags -> ByteOff
 -- Byte offset of the closure type half-word
@@ -585,7 +586,7 @@
 
 stdPtrsOffset, stdNonPtrsOffset :: DynFlags -> ByteOff
 stdPtrsOffset    dflags = stdInfoTableSizeB dflags - 2 * wORD_SIZE dflags
-stdNonPtrsOffset dflags = stdInfoTableSizeB dflags - 2 * wORD_SIZE dflags + hALF_WORD_SIZE dflags
+stdNonPtrsOffset dflags = stdInfoTableSizeB dflags - 2 * wORD_SIZE dflags + halfWordSize dflags
 
 conInfoTableSizeB :: DynFlags -> Int
 conInfoTableSizeB dflags = stdInfoTableSizeB dflags + wORD_SIZE dflags
diff --git a/compiler/cmm/CmmLint.hs b/compiler/cmm/CmmLint.hs
--- a/compiler/cmm/CmmLint.hs
+++ b/compiler/cmm/CmmLint.hs
@@ -21,7 +21,7 @@
 import CmmUtils
 import CmmLive
 import CmmSwitch (switchTargetsToList)
-import PprCmm ()
+import PprCmm () -- For Outputable instances
 import Outputable
 import DynFlags
 
diff --git a/compiler/cmm/CmmLive.hs b/compiler/cmm/CmmLive.hs
--- a/compiler/cmm/CmmLive.hs
+++ b/compiler/cmm/CmmLive.hs
@@ -17,7 +17,7 @@
 import DynFlags
 import BlockId
 import Cmm
-import PprCmmExpr ()
+import PprCmmExpr () -- For Outputable instances
 import Hoopl.Block
 import Hoopl.Collections
 import Hoopl.Dataflow
diff --git a/compiler/cmm/CmmProcPoint.hs b/compiler/cmm/CmmProcPoint.hs
--- a/compiler/cmm/CmmProcPoint.hs
+++ b/compiler/cmm/CmmProcPoint.hs
@@ -14,7 +14,7 @@
 import BlockId
 import CLabel
 import Cmm
-import PprCmm ()
+import PprCmm () -- For Outputable instances
 import CmmUtils
 import CmmInfo
 import CmmLive
diff --git a/compiler/cmm/CmmSink.hs b/compiler/cmm/CmmSink.hs
--- a/compiler/cmm/CmmSink.hs
+++ b/compiler/cmm/CmmSink.hs
@@ -19,7 +19,6 @@
 import DynFlags
 import Unique
 import UniqFM
-import PprCmm ()
 
 import qualified Data.IntSet as IntSet
 import Data.List (partition)
diff --git a/compiler/cmm/CmmUtils.hs b/compiler/cmm/CmmUtils.hs
--- a/compiler/cmm/CmmUtils.hs
+++ b/compiler/cmm/CmmUtils.hs
@@ -227,8 +227,8 @@
 --       but be careful: that's vulnerable when reversed
 packHalfWordsCLit dflags lower_half_word upper_half_word
    = if wORDS_BIGENDIAN dflags
-     then mkWordCLit dflags ((l `shiftL` hALF_WORD_SIZE_IN_BITS dflags) .|. u)
-     else mkWordCLit dflags (l .|. (u `shiftL` hALF_WORD_SIZE_IN_BITS dflags))
+     then mkWordCLit dflags ((l `shiftL` halfWordSizeInBits dflags) .|. u)
+     else mkWordCLit dflags (l .|. (u `shiftL` halfWordSizeInBits dflags))
     where l = fromStgHalfWord lower_half_word
           u = fromStgHalfWord upper_half_word
 
diff --git a/compiler/cmm/Debug.hs b/compiler/cmm/Debug.hs
--- a/compiler/cmm/Debug.hs
+++ b/compiler/cmm/Debug.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE MultiWayIf #-}
 
 -----------------------------------------------------------------------------
 --
@@ -11,7 +12,7 @@
 
 module Debug (
 
-  DebugBlock(..), dblIsEntry,
+  DebugBlock(..),
   cmmDebugGen,
   cmmDebugLabels,
   cmmDebugLink,
@@ -32,7 +33,6 @@
 import FastString      ( nilFS, mkFastString )
 import Module
 import Outputable
-import PprCore         ()
 import PprCmmExpr      ( pprExpr )
 import SrcLoc
 import Util            ( seqList )
@@ -59,8 +59,7 @@
   , dblParent     :: !(Maybe DebugBlock)
     -- ^ The parent of this proc. See Note [Splitting DebugBlocks]
   , dblTicks      :: ![CmmTickish] -- ^ Ticks defined in this block
-  , dblSourceTick
-            :: !(Maybe CmmTickish) -- ^ Best source tick covering block
+  , dblSourceTick :: !(Maybe CmmTickish) -- ^ Best source tick covering block
   , dblPosition   :: !(Maybe Int)  -- ^ Output position relative to
                                    -- other blocks. @Nothing@ means
                                    -- the block was optimized out
@@ -68,22 +67,19 @@
   , dblBlocks     :: ![DebugBlock] -- ^ Nested blocks
   }
 
--- | Is this the entry block?
-dblIsEntry :: DebugBlock -> Bool
-dblIsEntry blk = dblProcedure blk == dblLabel blk
-
 instance Outputable DebugBlock where
-  ppr blk = (if dblProcedure blk == dblLabel blk
-             then text "proc "
-             else if dblHasInfoTbl blk
-                  then text "pp-blk "
-                  else text "blk ") <>
+  ppr blk = (if | dblProcedure blk == dblLabel blk
+                -> text "proc"
+                | dblHasInfoTbl blk
+                -> text "pp-blk"
+                | otherwise
+                -> text "blk") <+>
             ppr (dblLabel blk) <+> parens (ppr (dblCLabel blk)) <+>
             (maybe empty ppr (dblSourceTick blk)) <+>
             (maybe (text "removed") ((text "pos " <>) . ppr)
                    (dblPosition blk)) <+>
-            (ppr (dblUnwind blk)) <+>
-            (if null (dblBlocks blk) then empty else ppr (dblBlocks blk))
+            (ppr (dblUnwind blk)) $+$
+            (if null (dblBlocks blk) then empty else nest 4 (ppr (dblBlocks blk)))
 
 -- | Intermediate data structure holding debug-relevant context information
 -- about a block.
diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs
--- a/compiler/cmm/PprC.hs
+++ b/compiler/cmm/PprC.hs
@@ -19,8 +19,7 @@
 -----------------------------------------------------------------------------
 
 module PprC (
-        writeCs,
-        pprStringInCStyle
+        writeC
   ) where
 
 #include "HsVersions.h"
@@ -32,7 +31,7 @@
 import CLabel
 import ForeignCall
 import Cmm hiding (pprBBlock)
-import PprCmm ()
+import PprCmm () -- For Outputable instances
 import Hoopl.Block
 import Hoopl.Collections
 import Hoopl.Graph
@@ -68,13 +67,8 @@
 -- --------------------------------------------------------------------------
 -- Top level
 
-pprCs :: [RawCmmGroup] -> SDoc
-pprCs cmms
- = pprCode CStyle (vcat $ map pprC cmms)
-
-writeCs :: DynFlags -> Handle -> [RawCmmGroup] -> IO ()
-writeCs dflags handle cmms
-  = printForC dflags handle (pprCs cmms)
+writeC :: DynFlags -> Handle -> RawCmmGroup -> IO ()
+writeC dflags handle cmm = printForC dflags handle (pprC cmm $$ blankLine)
 
 -- --------------------------------------------------------------------------
 -- Now do some real work
diff --git a/compiler/cmm/PprCmm.hs b/compiler/cmm/PprCmm.hs
--- a/compiler/cmm/PprCmm.hs
+++ b/compiler/cmm/PprCmm.hs
@@ -41,7 +41,6 @@
 
 import GhcPrelude hiding (succ)
 
-import BlockId ()
 import CLabel
 import Cmm
 import CmmUtils
@@ -52,7 +51,6 @@
 import PprCmmDecl
 import PprCmmExpr
 import Util
-import PprCore ()
 
 import BasicTypes
 import Hoopl.Block
diff --git a/compiler/cmm/SMRep.hs b/compiler/cmm/SMRep.hs
--- a/compiler/cmm/SMRep.hs
+++ b/compiler/cmm/SMRep.hs
@@ -13,7 +13,7 @@
 
         StgWord, fromStgWord, toStgWord,
         StgHalfWord, fromStgHalfWord, toStgHalfWord,
-        hALF_WORD_SIZE, hALF_WORD_SIZE_IN_BITS,
+        halfWordSize, halfWordSizeInBits,
 
         -- * Closure repesentation
         SMRep(..), -- CmmInfo sees the rep; no one else does
@@ -107,9 +107,8 @@
     = case platformWordSize (targetPlatform dflags) of
       -- These conversions mean that things like toStgWord (-1)
       -- do the right thing
-      4 -> StgWord (fromIntegral (fromInteger i :: Word32))
-      8 -> StgWord (fromInteger i :: Word64)
-      w -> panic ("toStgWord: Unknown platformWordSize: " ++ show w)
+      PW4 -> StgWord (fromIntegral (fromInteger i :: Word32))
+      PW8 -> StgWord (fromInteger i)
 
 instance Outputable StgWord where
     ppr (StgWord i) = integer (toInteger i)
@@ -129,17 +128,18 @@
     = case platformWordSize (targetPlatform dflags) of
       -- These conversions mean that things like toStgHalfWord (-1)
       -- do the right thing
-      4 -> StgHalfWord (fromIntegral (fromInteger i :: Word16))
-      8 -> StgHalfWord (fromInteger i :: Word32)
-      w -> panic ("toStgHalfWord: Unknown platformWordSize: " ++ show w)
+      PW4 -> StgHalfWord (fromIntegral (fromInteger i :: Word16))
+      PW8 -> StgHalfWord (fromInteger i :: Word32)
 
 instance Outputable StgHalfWord where
     ppr (StgHalfWord w) = integer (toInteger w)
 
-hALF_WORD_SIZE :: DynFlags -> ByteOff
-hALF_WORD_SIZE dflags = platformWordSize (targetPlatform dflags) `shiftR` 1
-hALF_WORD_SIZE_IN_BITS :: DynFlags -> Int
-hALF_WORD_SIZE_IN_BITS dflags = platformWordSize (targetPlatform dflags) `shiftL` 2
+-- | Half word size in bytes
+halfWordSize :: DynFlags -> ByteOff
+halfWordSize dflags = platformWordSizeInBytes (targetPlatform dflags) `div` 2
+
+halfWordSizeInBits :: DynFlags -> Int
+halfWordSizeInBits dflags = platformWordSizeInBits (targetPlatform dflags) `div` 2
 
 {-
 ************************************************************************
diff --git a/compiler/codeGen/StgCmmClosure.hs b/compiler/codeGen/StgCmmClosure.hs
--- a/compiler/codeGen/StgCmmClosure.hs
+++ b/compiler/codeGen/StgCmmClosure.hs
@@ -71,7 +71,7 @@
 import StgSyn
 import SMRep
 import Cmm
-import PprCmmExpr()
+import PprCmmExpr() -- For Outputable instances
 
 import CostCentre
 import BlockId
@@ -166,20 +166,27 @@
 
 -- Why are these here?
 
+-- | Assumes that there is precisely one 'PrimRep' of the type. This assumption
+-- holds after unarise.
+-- See Note [Post-unarisation invariants]
 idPrimRep :: Id -> PrimRep
 idPrimRep id = typePrimRep1 (idType id)
-    -- NB: typePrimRep1 fails on unboxed tuples,
-    --     but by StgCmm no Ids have unboxed tuple type
     -- See also Note [VoidRep] in RepType
 
+-- | Assumes that Ids have one PrimRep, which holds after unarisation.
+-- See Note [Post-unarisation invariants]
 addIdReps :: [NonVoid Id] -> [NonVoid (PrimRep, Id)]
 addIdReps = map (\id -> let id' = fromNonVoid id
                          in NonVoid (idPrimRep id', id'))
 
+-- | Assumes that arguments have one PrimRep, which holds after unarisation.
+-- See Note [Post-unarisation invariants]
 addArgReps :: [NonVoid StgArg] -> [NonVoid (PrimRep, StgArg)]
 addArgReps = map (\arg -> let arg' = fromNonVoid arg
                            in NonVoid (argPrimRep arg', arg'))
 
+-- | Assumes that the argument has one PrimRep, which holds after unarisation.
+-- See Note [Post-unarisation invariants]
 argPrimRep :: StgArg -> PrimRep
 argPrimRep arg = typePrimRep1 (stgArgType arg)
 
diff --git a/compiler/codeGen/StgCmmPrim.hs b/compiler/codeGen/StgCmmPrim.hs
--- a/compiler/codeGen/StgCmmPrim.hs
+++ b/compiler/codeGen/StgCmmPrim.hs
@@ -46,6 +46,7 @@
 import FastString
 import Outputable
 import Util
+import Data.Maybe
 
 import Data.Bits ((.&.), bit)
 import Control.Monad (liftM, when, unless)
@@ -872,43 +873,65 @@
      emit stmt
 
 emitPrimOp dflags results op args
-   = case callishPrimOpSupported dflags op of
+   = case callishPrimOpSupported dflags op args of
           Left op   -> emit $ mkUnsafeCall (PrimTarget op) results args
           Right gen -> gen results args
 
+-- Note [QuotRem optimization]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- `quot` and `rem` with constant divisor can be implemented with fast bit-ops
+-- (shift, .&.).
+--
+-- Currently we only support optimization (performed in CmmOpt) when the
+-- constant is a power of 2. #9041 tracks the implementation of the general
+-- optimization.
+--
+-- `quotRem` can be optimized in the same way. However as it returns two values,
+-- it is implemented as a "callish" primop which is harder to match and
+-- to transform later on. For simplicity, the current implementation detects cases
+-- that can be optimized (see `quotRemCanBeOptimized`) and converts STG quotRem
+-- primop into two CMM quot and rem primops.
+
 type GenericOp = [CmmFormal] -> [CmmActual] -> FCode ()
 
-callishPrimOpSupported :: DynFlags -> PrimOp -> Either CallishMachOp GenericOp
-callishPrimOpSupported dflags op
+callishPrimOpSupported :: DynFlags -> PrimOp -> [CmmExpr] -> Either CallishMachOp GenericOp
+callishPrimOpSupported dflags op args
   = case op of
-      IntQuotRemOp   | ncg && (x86ish || ppc) ->
-                         Left (MO_S_QuotRem  (wordWidth dflags))
-                     | otherwise              ->
-                         Right (genericIntQuotRemOp (wordWidth dflags))
+      IntQuotRemOp   | ncg && (x86ish || ppc)
+                     , not quotRemCanBeOptimized
+                         -> Left (MO_S_QuotRem  (wordWidth dflags))
+                     | otherwise
+                         -> Right (genericIntQuotRemOp (wordWidth dflags))
 
       Int8QuotRemOp  | ncg && (x86ish || ppc)
+                     , not quotRemCanBeOptimized
                                      -> Left (MO_S_QuotRem W8)
                      | otherwise     -> Right (genericIntQuotRemOp W8)
 
       Int16QuotRemOp | ncg && (x86ish || ppc)
+                     , not quotRemCanBeOptimized
                                      -> Left (MO_S_QuotRem W16)
                      | otherwise     -> Right (genericIntQuotRemOp W16)
 
 
-      WordQuotRemOp  | ncg && (x86ish || ppc) ->
-                         Left (MO_U_QuotRem  (wordWidth dflags))
-                     | otherwise      ->
-                         Right (genericWordQuotRemOp (wordWidth dflags))
+      WordQuotRemOp  | ncg && (x86ish || ppc)
+                     , not quotRemCanBeOptimized
+                         -> Left (MO_U_QuotRem  (wordWidth dflags))
+                     | otherwise
+                         -> Right (genericWordQuotRemOp (wordWidth dflags))
 
       WordQuotRem2Op | (ncg && (x86ish || ppc))
                           || llvm     -> Left (MO_U_QuotRem2 (wordWidth dflags))
                      | otherwise      -> Right (genericWordQuotRem2Op dflags)
 
       Word8QuotRemOp | ncg && (x86ish || ppc)
+                     , not quotRemCanBeOptimized
                                       -> Left (MO_U_QuotRem W8)
                      | otherwise      -> Right (genericWordQuotRemOp W8)
 
       Word16QuotRemOp| ncg && (x86ish || ppc)
+                     , not quotRemCanBeOptimized
                                      -> Left (MO_U_QuotRem W16)
                      | otherwise     -> Right (genericWordQuotRemOp W16)
 
@@ -944,6 +967,11 @@
 
       _ -> pprPanic "emitPrimOp: can't translate PrimOp " (ppr op)
  where
+  -- See Note [QuotRem optimization]
+  quotRemCanBeOptimized = case args of
+    [_, CmmLit (CmmInt n _) ] -> isJust (exactLog2 n)
+    _                         -> False
+
   ncg = case hscTarget dflags of
            HscAsm -> True
            _      -> False
diff --git a/compiler/deSugar/Check.hs b/compiler/deSugar/Check.hs
--- a/compiler/deSugar/Check.hs
+++ b/compiler/deSugar/Check.hs
@@ -56,7 +56,6 @@
 import Type
 import UniqSupply
 import DsUtils       (isTrueLHsExpr)
-import Maybes        (expectJust)
 import qualified GHC.LanguageExtensions as LangExt
 
 import Data.List     (find)
@@ -853,7 +852,7 @@
     alts_to_check :: Type -> Type -> [DataCon]
                   -> PmM (Either Type (TyCon, [InhabitationCandidate]))
     alts_to_check src_ty core_ty dcs = case splitTyConApp_maybe core_ty of
-      Just (tc, _)
+      Just (tc, tc_args)
         |  tc `elem` trivially_inhabited
         -> case dcs of
              []    -> return (Left src_ty)
@@ -869,7 +868,7 @@
            -- them extremely misleading.
         -> liftD $ do
              var  <- mkPmId core_ty -- it would be wrong to unify x
-             alts <- mapM (mkOneConFull var . RealDataCon) (tyConDataCons tc)
+             alts <- mapM (mkOneConFull var tc_args . RealDataCon) (tyConDataCons tc)
              return $ Right
                (tc, [ alt{ic_val_abs = build_tm (ic_val_abs alt) dcs}
                     | alt <- alts ])
@@ -1616,37 +1615,31 @@
 
 -- | Generate an 'InhabitationCandidate' for a given conlike (generate
 -- fresh variables of the appropriate type for arguments)
-mkOneConFull :: Id -> ConLike -> DsM InhabitationCandidate
---  *  x :: T tys, where T is an algebraic data type
---     NB: in the case of a data family, T is the *representation* TyCon
---     e.g.   data instance T (a,b) = T1 a b
---       leads to
---            data TPair a b = T1 a b  -- The "representation" type
---       It is TPair, not T, that is given to mkOneConFull
+mkOneConFull :: Id -> [Type] -> ConLike -> DsM InhabitationCandidate
+--  * 'con' K is a conlike of algebraic data type 'T tys'
+
+--  * 'tc_args' are the type arguments of the 'con's TyCon T
 --
---  * 'con' K is a conlike of data type T
+--  *  'x' is the variable for which we encode an equality constraint
+--     in the term oracle
 --
--- After instantiating the universal tyvars of K we get
---          K tys :: forall bs. Q => s1 .. sn -> T tys
+-- After instantiating the universal tyvars of K to tc_args we get
+--          K @tys :: forall bs. Q => s1 .. sn -> T tys
 --
 -- Suppose y1 is a strict field. Then we get
 -- Results: ic_val_abs:        K (y1::s1) .. (yn::sn)
 --          ic_tm_ct:          x ~ K y1..yn
 --          ic_ty_cs:          Q
 --          ic_strict_arg_tys: [s1]
-mkOneConFull x con = do
-  let res_ty  = idType x
-      (univ_tvs, ex_tvs, eq_spec, thetas, _req_theta , arg_tys, con_res_ty)
+mkOneConFull x tc_args con = do
+  let (univ_tvs, ex_tvs, eq_spec, thetas, _req_theta , arg_tys, _con_res_ty)
         = conLikeFullSig con
       arg_is_banged = map isBanged $ conLikeImplBangs con
-      tc_args = tyConAppArgs res_ty
-      subst1  = case con of
-                  RealDataCon {} -> zipTvSubst univ_tvs tc_args
-                  PatSynCon {}   -> expectJust "mkOneConFull" (tcMatchTy con_res_ty res_ty)
-                                    -- See Note [Pattern synonym result type] in PatSyn
+      subst1  = zipTvSubst univ_tvs tc_args
 
   (subst, ex_tvs') <- cloneTyVarBndrs subst1 ex_tvs <$> getUniqueSupplyM
 
+  -- Field types
   let arg_tys' = substTys subst arg_tys
   -- Fresh term variables (VAs) as arguments to the constructor
   arguments <-  mapM mkPmVar arg_tys'
@@ -2094,7 +2087,7 @@
           (PmVar x) (ValVec vva delta) = do
   (prov, complete_match) <- select =<< liftD (allCompleteMatches con tys)
 
-  cons_cs <- mapM (liftD . mkOneConFull x) complete_match
+  cons_cs <- mapM (liftD . mkOneConFull x tys) complete_match
 
   inst_vsa <- flip mapMaybeM cons_cs $
       \InhabitationCandidate{ ic_val_abs = va, ic_tm_ct = tm_ct
@@ -2201,11 +2194,11 @@
   u_1, ..., u_p are the universally quantified type variables.
 
 In the ConVar case, the coverage algorithm will have in hand the constructor
-K as well as a pattern variable (pv :: T PV_1 ... PV_p), where PV_1, ..., PV_p
-are some types that instantiate u_1, ... u_p. The idea is that we should
-substitute PV_1 for u_1, ..., and PV_p for u_p when forming a PmCon (the
-mkOneConFull function accomplishes this) and then hand this PmCon off to the
-ConCon case.
+K as well as a list of type arguments [t_1, ..., t_n] to substitute T's
+universally quantified type variables u_1, ..., u_n for. It's crucial to take
+these in as arguments, as it is non-trivial to derive them just from the result
+type of a pattern synonym and the ambient type of the match (#11336, #17112).
+The type checker already did the hard work, so we should just make use of it.
 
 The presence of existentially quantified type variables adds a significant
 wrinkle. We always grab e_1, ..., e_m from the definition of K to begin with,
diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs
--- a/compiler/deSugar/Coverage.hs
+++ b/compiler/deSugar/Coverage.hs
@@ -121,7 +121,7 @@
 guessSourceFile binds orig_file =
      -- Try look for a file generated from a .hsc file to a
      -- .hs file, by peeking ahead.
-     let top_pos = catMaybes $ foldrBag (\ (dL->L pos _) rest ->
+     let top_pos = catMaybes $ foldr (\ (dL->L pos _) rest ->
                                  srcSpanFileName_maybe pos : rest) [] binds
      in
      case top_pos of
diff --git a/compiler/deSugar/DsArrows.hs b/compiler/deSugar/DsArrows.hs
--- a/compiler/deSugar/DsArrows.hs
+++ b/compiler/deSugar/DsArrows.hs
@@ -50,7 +50,6 @@
 import BasicTypes
 import PrelNames
 import Outputable
-import Bag
 import VarSet
 import SrcLoc
 import ListSetOps( assocMaybe )
@@ -1251,7 +1250,7 @@
     go p@(XPat {})                = pprPanic "collectl/go" (ppr p)
 
 collectEvBinders :: TcEvBinds -> [Id]
-collectEvBinders (EvBinds bs)   = foldrBag add_ev_bndr [] bs
+collectEvBinders (EvBinds bs)   = foldr add_ev_bndr [] bs
 collectEvBinders (TcEvBinds {}) = panic "ToDo: collectEvBinders"
 
 add_ev_bndr :: EvBind -> [Id] -> [Id]
diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs
--- a/compiler/deSugar/DsBinds.hs
+++ b/compiler/deSugar/DsBinds.hs
@@ -1164,7 +1164,7 @@
   = map ds_scc (stronglyConnCompFromEdgedVerticesUniq edges)
   where
     edges :: [ Node EvVar (EvVar,CoreExpr) ]
-    edges = foldrBag ((:) . mk_node) [] ds_binds
+    edges = foldr ((:) . mk_node) [] ds_binds
 
     mk_node :: (Id, CoreExpr) -> Node EvVar (EvVar,CoreExpr)
     mk_node b@(var, rhs)
diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs
--- a/compiler/deSugar/DsExpr.hs
+++ b/compiler/deSugar/DsExpr.hs
@@ -187,7 +187,7 @@
                , abs_binds = lbinds }) body
   = do { let body1 = foldr bind_export body exports
              bind_export export b = bindNonRec (abe_poly export) (Var (abe_mono export)) b
-       ; body2 <- foldlBagM (\body lbind -> dsUnliftedBind (unLoc lbind) body)
+       ; body2 <- foldlM (\body lbind -> dsUnliftedBind (unLoc lbind) body)
                             body1 lbinds
        ; ds_binds <- dsTcEvBinds_s ev_binds
        ; return (mkCoreLets ds_binds body2) }
diff --git a/compiler/ghci/ByteCodeAsm.hs b/compiler/ghci/ByteCodeAsm.hs
--- a/compiler/ghci/ByteCodeAsm.hs
+++ b/compiler/ghci/ByteCodeAsm.hs
@@ -156,7 +156,11 @@
   return ubco'
 
 assembleBCO :: DynFlags -> ProtoBCO Name -> IO UnlinkedBCO
-assembleBCO dflags (ProtoBCO nm instrs bitmap bsize arity _origin _malloced) = do
+assembleBCO dflags (ProtoBCO { protoBCOName       = nm
+                             , protoBCOInstrs     = instrs
+                             , protoBCOBitmap     = bitmap
+                             , protoBCOBitmapSize = bsize
+                             , protoBCOArity      = arity }) = do
   -- pass 1: collect up the offsets of the local labels.
   let asm = mapM_ (assembleI dflags) instrs
 
diff --git a/compiler/ghci/ByteCodeGen.hs b/compiler/ghci/ByteCodeGen.hs
--- a/compiler/ghci/ByteCodeGen.hs
+++ b/compiler/ghci/ByteCodeGen.hs
@@ -27,6 +27,7 @@
 import Name
 import MkId
 import Id
+import Var             ( updateVarType )
 import ForeignCall
 import HscTypes
 import CoreUtils
@@ -62,7 +63,6 @@
 
 import UniqSupply
 import Module
-import Control.Arrow ( second )
 
 import Control.Exception
 import Data.Array
@@ -91,7 +91,7 @@
                 (const ()) $ do
         -- Split top-level binds into strings and others.
         -- See Note [generating code for top-level string literal bindings].
-        let (strings, flatBinds) = partitionEithers $ do
+        let (strings, flatBinds) = partitionEithers $ do  -- list monad
                 (bndr, rhs) <- flattenBinds binds
                 return $ case exprIsTickedString_maybe rhs of
                     Just str -> Left (bndr, str)
@@ -182,29 +182,13 @@
   where dflags = hsc_dflags hsc_env
 
 -- The regular freeVars function gives more information than is useful to
--- us here. simpleFreeVars does the impedance matching.
+-- us here. We need only the free variables, not everything in an FVAnn.
+-- Historical note: At one point FVAnn was more sophisticated than just
+-- a set. Now it isn't. So this function is much simpler. Keeping it around
+-- so that if someone changes FVAnn, they will get a nice type error right
+-- here.
 simpleFreeVars :: CoreExpr -> AnnExpr Id DVarSet
-simpleFreeVars = go . freeVars
-  where
-    go :: AnnExpr Id FVAnn -> AnnExpr Id DVarSet
-    go (ann, e) = (freeVarsOfAnn ann, go' e)
-
-    go' :: AnnExpr' Id FVAnn -> AnnExpr' Id DVarSet
-    go' (AnnVar id)                  = AnnVar id
-    go' (AnnLit lit)                 = AnnLit lit
-    go' (AnnLam bndr body)           = AnnLam bndr (go body)
-    go' (AnnApp fun arg)             = AnnApp (go fun) (go arg)
-    go' (AnnCase scrut bndr ty alts) = AnnCase (go scrut) bndr ty (map go_alt alts)
-    go' (AnnLet bind body)           = AnnLet (go_bind bind) (go body)
-    go' (AnnCast expr (ann, co))     = AnnCast (go expr) (freeVarsOfAnn ann, co)
-    go' (AnnTick tick body)          = AnnTick tick (go body)
-    go' (AnnType ty)                 = AnnType ty
-    go' (AnnCoercion co)             = AnnCoercion co
-
-    go_alt (con, args, expr) = (con, args, go expr)
-
-    go_bind (AnnNonRec bndr rhs) = AnnNonRec bndr (go rhs)
-    go_bind (AnnRec pairs)       = AnnRec (map (second go) pairs)
+simpleFreeVars = freeVars
 
 -- -----------------------------------------------------------------------------
 -- Compilation schema for the bytecode generator
@@ -257,6 +241,7 @@
    -> name
    -> BCInstrList
    -> Either  [AnnAlt Id DVarSet] (AnnExpr Id DVarSet)
+        -- ^ original expression; for debugging only
    -> Int
    -> Word16
    -> [StgWord]
@@ -369,6 +354,9 @@
 -}
    = schemeR_wrk fvs nm rhs (collect rhs)
 
+-- If an expression is a lambda (after apply bcView), return the
+-- list of arguments to the lambda (in R-to-L order) and the
+-- underlying expression
 collect :: AnnExpr Id DVarSet -> ([Var], AnnExpr' Id DVarSet)
 collect (_, e) = go [] e
   where
@@ -383,8 +371,8 @@
 schemeR_wrk
     :: [Id]
     -> Id
-    -> AnnExpr Id DVarSet
-    -> ([Var], AnnExpr' Var DVarSet)
+    -> AnnExpr Id DVarSet             -- expression e, for debugging only
+    -> ([Var], AnnExpr' Var DVarSet)  -- result of collect on e
     -> BcM (ProtoBCO Name)
 schemeR_wrk fvs nm original_body (args, body)
    = do
@@ -509,6 +497,8 @@
 schemeE d s p e@(AnnCoercion {}) = returnUnboxedAtom d s p e V
 
 schemeE d s p e@(AnnVar v)
+      -- See Note [Not-necessarily-lifted join points], step 3.
+    | isNNLJoinPoint v          = doTailCall d s p (protectNNLJoinPointId v) [AnnVar voidPrimId]
     | isUnliftedType (idType v) = returnUnboxedAtom d s p e (bcIdArgRep v)
     | otherwise                 = schemeT d s p e
 
@@ -535,19 +525,22 @@
 
          fvss  = map (fvsToEnv p' . fst) rhss
 
+           -- See Note [Not-necessarily-lifted join points], step 2.
+         (xs',rhss') = zipWithAndUnzip protectNNLJoinPointBind xs rhss
+
          -- Sizes of free vars
          size_w = trunc16W . idSizeW dflags
          sizes = map (\rhs_fvs -> sum (map size_w rhs_fvs)) fvss
 
          -- the arity of each rhs
-         arities = map (genericLength . fst . collect) rhss
+         arities = map (genericLength . fst . collect) rhss'
 
          -- This p', d' defn is safe because all the items being pushed
          -- are ptrs, so all have size 1 word.  d' and p' reflect the stack
          -- after the closures have been allocated in the heap (but not
          -- filled in), and pointers to them parked on the stack.
          offsets = mkStackOffsets d (genericReplicate n_binds (wordSize dflags))
-         p' = Map.insertList (zipE xs offsets) p
+         p' = Map.insertList (zipE xs' offsets) p
          d' = d + wordsToBytes dflags n_binds
          zipE = zipEqual "schemeE"
 
@@ -588,7 +581,7 @@
          compile_binds =
             [ compile_bind d' fvs x rhs size arity (trunc16W n)
             | (fvs, x, rhs, size, arity, n) <-
-                zip6 fvss xs rhss sizes arities [n_binds, n_binds-1 .. 1]
+                zip6 fvss xs' rhss' sizes arities [n_binds, n_binds-1 .. 1]
             ]
      body_code <- schemeE d' s p' body
      thunk_codes <- sequence compile_binds
@@ -682,6 +675,30 @@
    = pprPanic "ByteCodeGen.schemeE: unhandled case"
                (pprCoreExpr (deAnnotate' expr))
 
+-- Is this Id a not-necessarily-lifted join point?
+-- See Note [Not-necessarily-lifted join points], step 1
+isNNLJoinPoint :: Id -> Bool
+isNNLJoinPoint x = isJoinId x &&
+                   Just True /= isLiftedType_maybe (idType x)
+
+-- If necessary, modify this Id and body to protect not-necessarily-lifted join points.
+-- See Note [Not-necessarily-lifted join points], step 2.
+protectNNLJoinPointBind :: Id -> AnnExpr Id DVarSet -> (Id, AnnExpr Id DVarSet)
+protectNNLJoinPointBind x rhs@(fvs, _)
+  | isNNLJoinPoint x
+  = (protectNNLJoinPointId x, (fvs, AnnLam voidArgId rhs))
+
+  | otherwise
+  = (x, rhs)
+
+-- Update an Id's type to take a Void# argument.
+-- Precondition: the Id is a not-necessarily-lifted join point.
+-- See Note [Not-necessarily-lifted join points]
+protectNNLJoinPointId :: Id -> Id
+protectNNLJoinPointId x
+  = ASSERT( isNNLJoinPoint x )
+    updateVarType (voidPrimTy `mkVisFunTy`) x
+
 {-
    Ticked Expressions
    ------------------
@@ -689,6 +706,64 @@
   The idea is that the "breakpoint<n,fvs> E" is really just an annotation on
   the code. When we find such a thing, we pull out the useful information,
   and then compile the code as if it was just the expression E.
+
+Note [Not-necessarily-lifted join points]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+A join point variable is essentially a goto-label: it is, for example,
+never used as an argument to another function, and it is called only
+in tail position. See Note [Join points] and Note [Invariants on join points],
+both in CoreSyn. Because join points do not compile to true, red-blooded
+variables (with, e.g., registers allocated to them), they are allowed
+to be levity-polymorphic. (See invariant #6 in Note [Invariants on join points]
+in CoreSyn.)
+
+However, in this byte-code generator, join points *are* treated just as
+ordinary variables. There is no check whether a binding is for a join point
+or not; they are all treated uniformly. (Perhaps there is a missed optimization
+opportunity here, but that is beyond the scope of my (Richard E's) Thursday.)
+
+We thus must have *some* strategy for dealing with levity-polymorphic and
+unlifted join points. Levity-polymorphic variables are generally not allowed
+(though levity-polymorphic join points *are*; see Note [Invariants on join points]
+in CoreSyn, point 6), and we don't wish to evaluate unlifted join points eagerly.
+The questionable join points are *not-necessarily-lifted join points*
+(NNLJPs). (Not having such a strategy led to #16509, which panicked in the
+isUnliftedType check in the AnnVar case of schemeE.) Here is the strategy:
+
+1. Detect NNLJPs. This is done in isNNLJoinPoint.
+
+2. When binding an NNLJP, add a `\ (_ :: Void#) ->` to its RHS, and modify the
+   type to tack on a `Void# ->`. (Void# is written voidPrimTy within GHC.)
+   Note that functions are never levity-polymorphic, so this transformation
+   changes an NNLJP to a non-levity-polymorphic join point. This is done
+   in protectNNLJoinPointBind, called from the AnnLet case of schemeE.
+
+3. At an occurrence of an NNLJP, add an application to void# (called voidPrimId),
+   being careful to note the new type of the NNLJP. This is done in the AnnVar
+   case of schemeE, with help from protectNNLJoinPointId.
+
+Here is an example. Suppose we have
+
+  f = \(r :: RuntimeRep) (a :: TYPE r) (x :: T).
+      join j :: a
+           j = error @r @a "bloop"
+      in case x of
+           A -> j
+           B -> j
+           C -> error @r @a "blurp"
+
+Our plan is to behave is if the code was
+
+  f = \(r :: RuntimeRep) (a :: TYPE r) (x :: T).
+      let j :: (Void# -> a)
+          j = \ _ -> error @r @a "bloop"
+      in case x of
+           A -> j void#
+           B -> j void#
+           C -> error @r @a "blurp"
+
+It's a bit hacky, but it works well in practice and is local. I suspect the
+Right Fix is to take advantage of join points as goto-labels.
 
 -}
 
diff --git a/compiler/ghci/ByteCodeInstr.hs b/compiler/ghci/ByteCodeInstr.hs
--- a/compiler/ghci/ByteCodeInstr.hs
+++ b/compiler/ghci/ByteCodeInstr.hs
@@ -45,7 +45,7 @@
         protoBCOBitmap     :: [StgWord],
         protoBCOBitmapSize :: Word16,
         protoBCOArity      :: Int,
-        -- what the BCO came from
+        -- what the BCO came from, for debugging only
         protoBCOExpr       :: Either  [AnnAlt Id DVarSet] (AnnExpr Id DVarSet),
         -- malloc'd pointers
         protoBCOFFIs       :: [FFIInfo]
@@ -179,7 +179,13 @@
 -- Printing bytecode instructions
 
 instance Outputable a => Outputable (ProtoBCO a) where
-   ppr (ProtoBCO name instrs bitmap bsize arity origin ffis)
+   ppr (ProtoBCO { protoBCOName       = name
+                 , protoBCOInstrs     = instrs
+                 , protoBCOBitmap     = bitmap
+                 , protoBCOBitmapSize = bsize
+                 , protoBCOArity      = arity
+                 , protoBCOExpr       = origin
+                 , protoBCOFFIs       = ffis })
       = (text "ProtoBCO" <+> ppr name <> char '#' <> int arity
                 <+> text (show ffis) <> colon)
         $$ nest 3 (case origin of
diff --git a/compiler/hieFile/HieAst.hs b/compiler/hieFile/HieAst.hs
--- a/compiler/hieFile/HieAst.hs
+++ b/compiler/hieFile/HieAst.hs
@@ -38,6 +38,7 @@
 import Var                        ( Id, Var, setVarName, varName, varType )
 import TcRnTypes
 import MkIface                    ( mkIfaceExports )
+import Panic
 
 import HieTypes
 import HieUtils
@@ -161,7 +162,7 @@
 
 grhss_span :: GRHSs p body -> SrcSpan
 grhss_span (GRHSs _ xs bs) = foldl' combineSrcSpans (getLoc bs) (map getLoc xs)
-grhss_span (XGRHSs _) = error "XGRHS has no span"
+grhss_span (XGRHSs _) = panic "XGRHS has no span"
 
 bindingsOnly :: [Context Name] -> [HieAST a]
 bindingsOnly [] = []
@@ -245,7 +246,7 @@
   -> [LPat (GhcPass p)]
   -> [PScoped (LPat (GhcPass p))]
 patScopes rsp useScope patScope xs =
-  map (\(RS sc a) -> PS rsp useScope sc (unLoc a)) $
+  map (\(RS sc a) -> PS rsp useScope sc (composeSrcSpan a)) $
     listScopes patScope (map dL xs)
 
 -- | 'listScopes' specialised to 'TVScoped' things
@@ -300,7 +301,8 @@
 instance ProtectSig GhcRn where
   protectSig sc (HsWC a (HsIB b sig)) =
     HsWC a (HsIB b (SH sc sig))
-  protectSig _ _ = error "protectSig not given HsWC (HsIB)"
+  protectSig _ (HsWC _ (XHsImplicitBndrs nec)) = noExtCon nec
+  protectSig _ (XHsWildCardBndrs nec) = noExtCon nec
 
 class HasLoc a where
   -- ^ defined so that HsImplicitBndrs and HsWildCardBndrs can
@@ -351,6 +353,21 @@
 instance HasLoc (Pat (GhcPass a)) where
   loc (dL -> L l _) = l
 
+{- Note [Real DataCon Name]
+The typechecker subtitutes the conLikeWrapId for the name, but we don't want
+this showing up in the hieFile, so we replace the name in the Id with the
+original datacon name
+See also Note [Data Constructor Naming]
+-}
+class HasRealDataConName p where
+  getRealDataCon :: XRecordCon p -> Located (IdP p) -> Located (IdP p)
+
+instance HasRealDataConName GhcRn where
+  getRealDataCon _ n = n
+instance HasRealDataConName GhcTc where
+  getRealDataCon RecordConTc{rcon_con_like = con} (L sp var) =
+    L sp (setVarName var (conLikeName con))
+
 -- | The main worker class
 class ToHie a where
   toHie :: a -> HieM [HieAST Type]
@@ -737,6 +754,7 @@
          , Data (HsSplice a)
          , Data (HsTupArg a)
          , Data (AmbiguousFieldOcc a)
+         , (HasRealDataConName a)
          ) => ToHie (LHsExpr (GhcPass p)) where
   toHie e@(L mspan oexpr) = concatM $ getTypeNode e : case oexpr of
       HsVar _ (L _ var) ->
@@ -817,8 +835,9 @@
       ExplicitList _ _ exprs ->
         [ toHie exprs
         ]
-      RecordCon {rcon_con_name = name, rcon_flds = binds}->
-        [ toHie $ C Use name
+      RecordCon {rcon_ext = mrealcon, rcon_con_name = name, rcon_flds = binds} ->
+        [ toHie $ C Use (getRealDataCon @a mrealcon name)
+            -- See Note [Real DataCon Name]
         , toHie $ RC RecFieldAssign $ binds
         ]
       RecordUpd {rupd_expr = expr, rupd_flds = upds}->
diff --git a/compiler/hieFile/HieBin.hs b/compiler/hieFile/HieBin.hs
--- a/compiler/hieFile/HieBin.hs
+++ b/compiler/hieFile/HieBin.hs
@@ -2,7 +2,7 @@
 Binary serialization for .hie files.
 -}
 {-# LANGUAGE ScopedTypeVariables #-}
-module HieBin ( readHieFile, readHieFileWithVersion, HieHeader, writeHieFile, HieName(..), toHieName, HieFileResult(..), hieMagic) where
+module HieBin ( readHieFile, readHieFileWithVersion, HieHeader, writeHieFile, HieName(..), toHieName, HieFileResult(..), hieMagic, hieNameOcc) where
 
 import GHC.Settings               ( maybeRead )
 
@@ -58,6 +58,15 @@
   ppr (ExternalName m n sp) = text "ExternalName" <+> ppr m <+> ppr n <+> ppr sp
   ppr (LocalName n sp) = text "LocalName" <+> ppr n <+> ppr sp
   ppr (KnownKeyName u) = text "KnownKeyName" <+> ppr u
+
+hieNameOcc :: HieName -> OccName
+hieNameOcc (ExternalName _ occ _) = occ
+hieNameOcc (LocalName occ _) = occ
+hieNameOcc (KnownKeyName u) =
+  case lookupKnownKeyName u of
+    Just n -> nameOccName n
+    Nothing -> pprPanic "hieNameOcc:unknown known-key unique"
+                        (ppr (unpkUnique u))
 
 
 data HieSymbolTable = HieSymbolTable
diff --git a/compiler/hieFile/HieDebug.hs b/compiler/hieFile/HieDebug.hs
--- a/compiler/hieFile/HieDebug.hs
+++ b/compiler/hieFile/HieDebug.hs
@@ -16,6 +16,7 @@
 import HieTypes
 import HieBin
 import HieUtils
+import Name
 
 import qualified Data.Map as M
 import qualified Data.Set as S
@@ -56,20 +57,30 @@
 diffFile :: Diff HieFile
 diffFile = diffAsts eqDiff `on` (getAsts . hie_asts)
 
-diffAsts :: (Outputable a, Eq a) => Diff a -> Diff (M.Map FastString (HieAST a))
+diffAsts :: (Outputable a, Eq a, Ord a) => Diff a -> Diff (M.Map FastString (HieAST a))
 diffAsts f = diffList (diffAst f) `on` M.elems
 
-diffAst :: (Outputable a, Eq a) => Diff a -> Diff (HieAST a)
+diffAst :: (Outputable a, Eq a,Ord a) => Diff a -> Diff (HieAST a)
 diffAst diffType (Node info1 span1 xs1) (Node info2 span2 xs2) =
     infoDiff ++ spanDiff ++ diffList (diffAst diffType) xs1 xs2
   where
     spanDiff
       | span1 /= span2 = [hsep ["Spans", ppr span1, "and", ppr span2, "differ"]]
       | otherwise = []
-    infoDiff
+    infoDiff'
       = (diffList eqDiff `on` (S.toAscList . nodeAnnotations)) info1 info2
      ++ (diffList diffType `on` nodeType) info1 info2
      ++ (diffIdents `on` nodeIdentifiers) info1 info2
+    infoDiff = case infoDiff' of
+      [] -> []
+      xs -> xs ++ [vcat ["In Node:",ppr (nodeIdentifiers info1,span1)
+                           , "and", ppr (nodeIdentifiers info2,span2)
+                        , "While comparing"
+                        , ppr (normalizeIdents $ nodeIdentifiers info1), "and"
+                        , ppr (normalizeIdents $ nodeIdentifiers info2)
+                        ]
+                  ]
+
     diffIdents a b = (diffList diffIdent `on` normalizeIdents) a b
     diffIdent (a,b) (c,d) = diffName a c
                          ++ eqDiff b d
@@ -81,10 +92,11 @@
 
 type DiffIdent = Either ModuleName HieName
 
-normalizeIdents :: NodeIdentifiers a -> [(DiffIdent,IdentifierDetails a)]
-normalizeIdents = sortOn fst . map (first toHieName) . M.toList
+normalizeIdents :: Ord a => NodeIdentifiers a -> [(DiffIdent,IdentifierDetails a)]
+normalizeIdents = sortOn go . map (first toHieName) . M.toList
   where
     first f (a,b) = (fmap f a, b)
+    go (a,b) = (hieNameOcc <$> a,identInfo b,identType b)
 
 diffList :: Diff a -> Diff [a]
 diffList f xs ys
@@ -122,10 +134,14 @@
 
 -- | Look for any identifiers which occur outside of their supposed scopes.
 -- Returns a list of error messages.
-validateScopes :: M.Map FastString (HieAST a) -> [SDoc]
-validateScopes asts = M.foldrWithKey (\k a b -> valid k a ++ b) [] refMap
+validateScopes :: Module -> M.Map FastString (HieAST a) -> [SDoc]
+validateScopes mod asts = validScopes
   where
     refMap = generateReferencesMap asts
+    -- We use a refmap for most of the computation
+
+    -- Check if all the names occur in their calculated scopes
+    validScopes = M.foldrWithKey (\k a b -> valid k a ++ b) [] refMap
     valid (Left _) _ = []
     valid (Right n) refs = concatMap inScope refs
       where
@@ -134,13 +150,22 @@
           Just xs -> xs
           Nothing -> []
         inScope (sp, dets)
-          |  definedInAsts asts n
+          |  (definedInAsts asts n)
           && any isOccurrence (identInfo dets)
+          -- We validate scopes for names which are defined locally, and occur
+          -- in this span
             = case scopes of
-              [] -> []
+              [] | (nameIsLocalOrFrom mod n
+                   && not (isDerivedOccName $ nameOccName n))
+                   -- If we don't get any scopes for a local name then its an error.
+                   -- We can ignore derived names.
+                   -> return $ hsep $
+                     [ "Locally defined Name", ppr n,pprDefinedAt n , "at position", ppr sp
+                     , "Doesn't have a calculated scope: ", ppr scopes]
+                 | otherwise -> []
               _ -> if any (`scopeContainsSpan` sp) scopes
                    then []
                    else return $ hsep $
-                     [ "Name", ppr n, "at position", ppr sp
+                     [ "Name", ppr n, pprDefinedAt n, "at position", ppr sp
                      , "doesn't occur in calculated scope", ppr scopes]
           | otherwise = []
diff --git a/compiler/iface/FlagChecker.hs b/compiler/iface/FlagChecker.hs
--- a/compiler/iface/FlagChecker.hs
+++ b/compiler/iface/FlagChecker.hs
@@ -11,7 +11,6 @@
 import GhcPrelude
 
 import Binary
-import BinIface ()
 import DynFlags
 import HscTypes
 import Module
diff --git a/compiler/iface/LoadIface.hs b/compiler/iface/LoadIface.hs
--- a/compiler/iface/LoadIface.hs
+++ b/compiler/iface/LoadIface.hs
@@ -399,7 +399,8 @@
        -- Redo search for our local hole module
        loadInterface doc_str (mkModule (thisPackage dflags) (moduleName mod)) from
   | otherwise
-  = do  {       -- Read the state
+  = withTiming getDynFlags (text "loading interface") (pure ()) $
+    do  {       -- Read the state
           (eps,hpt) <- getEpsAndHpt
         ; gbl_env <- getGblEnv
 
diff --git a/compiler/iface/MkIface.hs b/compiler/iface/MkIface.hs
--- a/compiler/iface/MkIface.hs
+++ b/compiler/iface/MkIface.hs
@@ -1804,33 +1804,30 @@
  where
    branch_list = fromBranches branches
 
--- 2nd parameter is the list of branch LHSs, for conversion from incompatible branches
--- to incompatible indices
+-- 2nd parameter is the list of branch LHSs, in case of a closed type family,
+-- for conversion from incompatible branches to incompatible indices.
+-- For an open type family the list should be empty.
 -- See Note [Storing compatibility] in CoAxiom
 coAxBranchToIfaceBranch :: TyCon -> [[Type]] -> CoAxBranch -> IfaceAxBranch
 coAxBranchToIfaceBranch tc lhs_s
-                        branch@(CoAxBranch { cab_incomps = incomps })
-  = (coAxBranchToIfaceBranch' tc branch) { ifaxbIncomps = iface_incomps }
+                        (CoAxBranch { cab_tvs = tvs, cab_cvs = cvs
+                                    , cab_eta_tvs = eta_tvs
+                                    , cab_lhs = lhs, cab_roles = roles
+                                    , cab_rhs = rhs, cab_incomps = incomps })
+
+  = IfaceAxBranch { ifaxbTyVars  = toIfaceTvBndrs tvs
+                  , ifaxbCoVars  = map toIfaceIdBndr cvs
+                  , ifaxbEtaTyVars = toIfaceTvBndrs eta_tvs
+                  , ifaxbLHS     = toIfaceTcArgs tc lhs
+                  , ifaxbRoles   = roles
+                  , ifaxbRHS     = toIfaceType rhs
+                  , ifaxbIncomps = iface_incomps }
   where
     iface_incomps = map (expectJust "iface_incomps"
-                        . (flip findIndex lhs_s
-                          . eqTypes)
+                        . flip findIndex lhs_s
+                        . eqTypes
                         . coAxBranchLHS) incomps
 
--- use this one for standalone branches without incompatibles
-coAxBranchToIfaceBranch' :: TyCon -> CoAxBranch -> IfaceAxBranch
-coAxBranchToIfaceBranch' tc (CoAxBranch { cab_tvs = tvs, cab_cvs = cvs
-                                        , cab_eta_tvs = eta_tvs
-                                        , cab_lhs = lhs
-                                        , cab_roles = roles, cab_rhs = rhs })
-  = IfaceAxBranch { ifaxbTyVars    = toIfaceTvBndrs tvs
-                  , ifaxbCoVars    = map toIfaceIdBndr cvs
-                  , ifaxbEtaTyVars = toIfaceTvBndrs eta_tvs
-                  , ifaxbLHS       = toIfaceTcArgs tc lhs
-                  , ifaxbRoles     = roles
-                  , ifaxbRHS       = toIfaceType rhs
-                  , ifaxbIncomps   = [] }
-
 -----------------
 tyConToIfaceDecl :: TidyEnv -> TyCon -> (TidyEnv, IfaceDecl)
 -- We *do* tidy TyCons, because they are not (and cannot
@@ -1911,7 +1908,8 @@
     to_if_fam_flav (ClosedSynFamilyTyCon (Just ax))
       = IfaceClosedSynFamilyTyCon (Just (axn, ibr))
       where defs = fromBranches $ coAxiomBranches ax
-            ibr  = map (coAxBranchToIfaceBranch' tycon) defs
+            lhss = map coAxBranchLHS defs
+            ibr  = map (coAxBranchToIfaceBranch tycon lhss) defs
             axn  = coAxiomName ax
 
     ifaceConDecls (NewTyCon { data_con = con })    = IfNewTyCon  (ifaceConDecl con)
diff --git a/compiler/llvmGen/LlvmCodeGen.hs b/compiler/llvmGen/LlvmCodeGen.hs
--- a/compiler/llvmGen/LlvmCodeGen.hs
+++ b/compiler/llvmGen/LlvmCodeGen.hs
@@ -1,9 +1,9 @@
-{-# LANGUAGE CPP, TypeFamilies, ViewPatterns #-}
+{-# LANGUAGE CPP, TypeFamilies, ViewPatterns, OverloadedStrings #-}
 
 -- -----------------------------------------------------------------------------
 -- | This is the top-level module in the LLVM code generator.
 --
-module LlvmCodeGen ( LlvmVersion (..), llvmCodeGen, llvmFixupAsm ) where
+module LlvmCodeGen ( LlvmVersion, llvmVersionList, llvmCodeGen, llvmFixupAsm ) where
 
 #include "HsVersions.h"
 
@@ -34,7 +34,7 @@
 import SysTools ( figureLlvmVersion )
 import qualified Stream
 
-import Control.Monad ( when )
+import Control.Monad ( when, forM_ )
 import Data.Maybe ( fromMaybe, catMaybes )
 import System.IO
 
@@ -42,8 +42,8 @@
 -- | Top-level of the LLVM Code generator
 --
 llvmCodeGen :: DynFlags -> Handle -> UniqSupply
-               -> Stream.Stream IO RawCmmGroup ()
-               -> IO ()
+               -> Stream.Stream IO RawCmmGroup a
+               -> IO a
 llvmCodeGen dflags h us cmm_stream
   = withTiming (pure dflags) (text "LLVM CodeGen") (const ()) $ do
        bufh <- newBufHandle h
@@ -52,26 +52,28 @@
        showPass dflags "LLVM CodeGen"
 
        -- get llvm version, cache for later use
-       ver <- (fromMaybe supportedLlvmVersion) `fmap` figureLlvmVersion dflags
+       mb_ver <- figureLlvmVersion dflags
 
        -- warn if unsupported
-       debugTraceMsg dflags 2
-            (text "Using LLVM version:" <+> text (show ver))
-       let doWarn = wopt Opt_WarnUnsupportedLlvmVersion dflags
-       when (ver /= supportedLlvmVersion && doWarn) $
-           putMsg dflags (text "You are using an unsupported version of LLVM!"
-                            $+$ text ("Currently only " ++
-                                      llvmVersionStr supportedLlvmVersion ++
-                                      " is supported.")
-                            $+$ text "We will try though...")
+       forM_ mb_ver $ \ver -> do
+         debugTraceMsg dflags 2
+              (text "Using LLVM version:" <+> text (llvmVersionStr ver))
+         let doWarn = wopt Opt_WarnUnsupportedLlvmVersion dflags
+         when (not (llvmVersionSupported ver) && doWarn) $ putMsg dflags $
+           "You are using an unsupported version of LLVM!" $$
+           "Currently only " <> text (llvmVersionStr supportedLlvmVersion) <> " is supported." <+>
+           "System LLVM version: " <> text (llvmVersionStr ver) $$
+           "We will try though..."
 
        -- run code generation
-       runLlvm dflags ver bufh us $
+       a <- runLlvm dflags (fromMaybe supportedLlvmVersion mb_ver) bufh us $
          llvmCodeGen' (liftStream cmm_stream)
 
        bFlush bufh
 
-llvmCodeGen' :: Stream.Stream LlvmM RawCmmGroup () -> LlvmM ()
+       return a
+
+llvmCodeGen' :: Stream.Stream LlvmM RawCmmGroup a -> LlvmM a
 llvmCodeGen' cmm_stream
   = do  -- Preamble
         renderLlvm header
@@ -79,14 +81,15 @@
         cmmMetaLlvmPrelude
 
         -- Procedures
-        let llvmStream = Stream.mapM llvmGroupLlvmGens cmm_stream
-        _ <- Stream.collect llvmStream
+        a <- Stream.consume cmm_stream llvmGroupLlvmGens
 
         -- Declare aliases for forward references
         renderLlvm . pprLlvmData =<< generateExternDecls
 
         -- Postamble
         cmmUsedLlvmGens
+
+        return a
   where
     header :: SDoc
     header = sdocWithDynFlags $ \dflags ->
diff --git a/compiler/llvmGen/LlvmCodeGen/Base.hs b/compiler/llvmGen/LlvmCodeGen/Base.hs
--- a/compiler/llvmGen/LlvmCodeGen/Base.hs
+++ b/compiler/llvmGen/LlvmCodeGen/Base.hs
@@ -13,7 +13,8 @@
         LiveGlobalRegs,
         LlvmUnresData, LlvmData, UnresLabel, UnresStatic,
 
-        LlvmVersion (..), supportedLlvmVersion, llvmVersionStr,
+        LlvmVersion, supportedLlvmVersion, llvmVersionSupported, parseLlvmVersion,
+        llvmVersionStr, llvmVersionList,
 
         LlvmM,
         runLlvm, liftStream, withClearVars, varLookup, varInsert,
@@ -60,6 +61,9 @@
 
 import Data.Maybe (fromJust)
 import Control.Monad (ap)
+import Data.Char (isDigit)
+import Data.List (intercalate)
+import qualified Data.List.NonEmpty as NE
 
 -- ----------------------------------------------------------------------------
 -- * Some Data Types
@@ -176,27 +180,36 @@
 -- * Llvm Version
 --
 
--- | LLVM Version Number
-data LlvmVersion
-    = LlvmVersion Int
-    | LlvmVersionOld Int Int
-    deriving Eq
+-- Newtype to avoid using the Eq instance!
+newtype LlvmVersion = LlvmVersion { llvmVersionNE :: NE.NonEmpty Int }
 
--- Custom show instance for backwards compatibility.
-instance Show LlvmVersion where
-  show (LlvmVersion maj) = show maj
-  show (LlvmVersionOld maj min) = show maj ++ "." ++ show min
+parseLlvmVersion :: String -> Maybe LlvmVersion
+parseLlvmVersion =
+    fmap LlvmVersion . NE.nonEmpty . go [] . dropWhile (not . isDigit)
+  where
+    go vs s
+      | null ver_str
+      = reverse vs
+      | '.' : rest' <- rest
+      = go (read ver_str : vs) rest'
+      | otherwise
+      = reverse (read ver_str : vs)
+      where
+        (ver_str, rest) = span isDigit s
 
 -- | The LLVM Version that is currently supported.
 supportedLlvmVersion :: LlvmVersion
-supportedLlvmVersion = LlvmVersion sUPPORTED_LLVM_VERSION
+supportedLlvmVersion = LlvmVersion (sUPPORTED_LLVM_VERSION NE.:| [])
 
+llvmVersionSupported :: LlvmVersion -> Bool
+llvmVersionSupported (LlvmVersion v) = NE.head v == sUPPORTED_LLVM_VERSION
+
 llvmVersionStr :: LlvmVersion -> String
-llvmVersionStr v =
-  case v of
-    LlvmVersion maj -> show maj
-    LlvmVersionOld maj min -> show maj ++ "." ++ show min
+llvmVersionStr = intercalate "." . map show . llvmVersionList
 
+llvmVersionList :: LlvmVersion -> [Int]
+llvmVersionList = NE.toList . llvmVersionNE
+
 -- ----------------------------------------------------------------------------
 -- * Environment Handling
 --
@@ -253,10 +266,10 @@
                               return (x, env)
 
 -- | Get initial Llvm environment.
-runLlvm :: DynFlags -> LlvmVersion -> BufHandle -> UniqSupply -> LlvmM () -> IO ()
+runLlvm :: DynFlags -> LlvmVersion -> BufHandle -> UniqSupply -> LlvmM a -> IO a
 runLlvm dflags ver out us m = do
-    _ <- runLlvmM m env
-    return ()
+    (a, _) <- runLlvmM m env
+    return a
   where env = LlvmEnv { envFunMap = emptyUFM
                       , envVarMap = emptyUFM
                       , envStackRegs = []
diff --git a/compiler/main/CodeOutput.hs b/compiler/main/CodeOutput.hs
--- a/compiler/main/CodeOutput.hs
+++ b/compiler/main/CodeOutput.hs
@@ -12,19 +12,19 @@
 
 import GhcPrelude
 
-import AsmCodeGen ( nativeCodeGen )
-import LlvmCodeGen ( llvmCodeGen )
+import AsmCodeGen       ( nativeCodeGen )
+import LlvmCodeGen      ( llvmCodeGen )
 
 import UniqSupply       ( mkSplitUniqSupply )
 
 import Finder           ( mkStubPaths )
-import PprC             ( writeCs )
+import PprC             ( writeC )
 import CmmLint          ( cmmLint )
 import Packages
 import Cmm              ( RawCmmGroup )
 import HscTypes
 import DynFlags
-import Stream           (Stream)
+import Stream           ( Stream )
 import qualified Stream
 import FileCleanup
 
@@ -54,10 +54,11 @@
            -> [(ForeignSrcLang, FilePath)]
            -- ^ additional files to be compiled with with the C compiler
            -> [InstalledUnitId]
-           -> Stream IO RawCmmGroup ()                       -- Compiled C--
+           -> Stream IO RawCmmGroup a                       -- Compiled C--
            -> IO (FilePath,
                   (Bool{-stub_h_exists-}, Maybe FilePath{-stub_c_exists-}),
-                  [(ForeignSrcLang, FilePath)]{-foreign_fps-})
+                  [(ForeignSrcLang, FilePath)]{-foreign_fps-},
+                  a)
 
 codeOutput dflags this_mod filenm location foreign_stubs foreign_fps pkg_deps
   cmm_stream
@@ -87,15 +88,14 @@
                 }
 
         ; stubs_exist <- outputForeignStubs dflags this_mod location foreign_stubs
-        ; case hscTarget dflags of {
-             HscAsm         -> outputAsm dflags this_mod location filenm
-                                         linted_cmm_stream;
-             HscC           -> outputC dflags filenm linted_cmm_stream pkg_deps;
-             HscLlvm        -> outputLlvm dflags filenm linted_cmm_stream;
-             HscInterpreted -> panic "codeOutput: HscInterpreted";
-             HscNothing     -> panic "codeOutput: HscNothing"
-          }
-        ; return (filenm, stubs_exist, foreign_fps)
+        ; a <- case hscTarget dflags of
+                 HscAsm         -> outputAsm dflags this_mod location filenm
+                                             linted_cmm_stream
+                 HscC           -> outputC dflags filenm linted_cmm_stream pkg_deps
+                 HscLlvm        -> outputLlvm dflags filenm linted_cmm_stream
+                 HscInterpreted -> panic "codeOutput: HscInterpreted"
+                 HscNothing     -> panic "codeOutput: HscNothing"
+        ; return (filenm, stubs_exist, foreign_fps, a)
         }
 
 doOutput :: String -> (Handle -> IO a) -> IO a
@@ -111,16 +111,13 @@
 
 outputC :: DynFlags
         -> FilePath
-        -> Stream IO RawCmmGroup ()
+        -> Stream IO RawCmmGroup a
         -> [InstalledUnitId]
-        -> IO ()
+        -> IO a
 
 outputC dflags filenm cmm_stream packages
   = do
-       -- ToDo: make the C backend consume the C-- incrementally, by
-       -- pushing the cmm_stream inside (c.f. nativeCodeGen)
-       rawcmms <- Stream.collect cmm_stream
-       withTiming (return dflags) (text "C codegen") id $ do
+       withTiming (return dflags) (text "C codegen") (\a -> seq a () {- FIXME -}) $ do
 
          -- figure out which header files to #include in the generated .hc file:
          --
@@ -142,7 +139,7 @@
          doOutput filenm $ \ h -> do
             hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n")
             hPutStr h cc_injects
-            writeCs dflags h rawcmms
+            Stream.consume cmm_stream (writeC dflags h)
 
 {-
 ************************************************************************
@@ -153,18 +150,17 @@
 -}
 
 outputAsm :: DynFlags -> Module -> ModLocation -> FilePath
-          -> Stream IO RawCmmGroup ()
-          -> IO ()
+          -> Stream IO RawCmmGroup a
+          -> IO a
 outputAsm dflags this_mod location filenm cmm_stream
  | platformMisc_ghcWithNativeCodeGen $ platformMisc dflags
   = do ncg_uniqs <- mkSplitUniqSupply 'n'
 
        debugTraceMsg dflags 4 (text "Outputing asm to" <+> text filenm)
 
-       _ <- {-# SCC "OutputAsm" #-} doOutput filenm $
+       {-# SCC "OutputAsm" #-} doOutput filenm $
            \h -> {-# SCC "NativeCodeGen" #-}
                  nativeCodeGen dflags this_mod location h ncg_uniqs cmm_stream
-       return ()
 
  | otherwise
   = panic "This compiler was built without a native code generator"
@@ -177,7 +173,7 @@
 ************************************************************************
 -}
 
-outputLlvm :: DynFlags -> FilePath -> Stream IO RawCmmGroup () -> IO ()
+outputLlvm :: DynFlags -> FilePath -> Stream IO RawCmmGroup a -> IO a
 outputLlvm dflags filenm cmm_stream
   = do ncg_uniqs <- mkSplitUniqSupply 'n'
 
diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs
--- a/compiler/main/DriverPipeline.hs
+++ b/compiler/main/DriverPipeline.hs
@@ -56,7 +56,7 @@
 import BasicTypes       ( SuccessFlag(..) )
 import Maybes           ( expectJust )
 import SrcLoc
-import LlvmCodeGen      ( LlvmVersion (..), llvmFixupAsm )
+import LlvmCodeGen      ( llvmFixupAsm, llvmVersionList )
 import MonadUtils
 import GHC.Platform
 import TcRnTypes
@@ -2039,10 +2039,10 @@
 getBackendDefs :: DynFlags -> IO [String]
 getBackendDefs dflags | hscTarget dflags == HscLlvm = do
     llvmVer <- figureLlvmVersion dflags
-    return $ case llvmVer of
-               Just (LlvmVersion n) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (n,0) ]
-               Just (LlvmVersionOld m n) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,n) ]
-               _      -> []
+    return $ case fmap llvmVersionList llvmVer of
+               Just [m] -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,0) ]
+               Just (m:n:_) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,n) ]
+               _ -> []
   where
     format (major, minor)
       | minor >= 100 = error "getBackendDefs: Unsupported minor version"
diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
--- a/compiler/main/GHC.hs
+++ b/compiler/main/GHC.hs
@@ -80,6 +80,7 @@
         modInfoIsExportedName,
         modInfoLookupName,
         modInfoIface,
+        modInfoRdrEnv,
         modInfoSafe,
         lookupGlobalName,
         findGlobalAnns,
@@ -1220,6 +1221,9 @@
 
 modInfoIface :: ModuleInfo -> Maybe ModIface
 modInfoIface = minf_iface
+
+modInfoRdrEnv :: ModuleInfo -> Maybe GlobalRdrEnv
+modInfoRdrEnv = minf_rdr_env
 
 -- | Retrieve module safe haskell mode
 modInfoSafe :: ModuleInfo -> SafeHaskellMode
diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs
--- a/compiler/main/HscMain.hs
+++ b/compiler/main/HscMain.hs
@@ -149,7 +149,6 @@
 
 import DynFlags
 import ErrUtils
-import GHC.Platform ( platformOS, osSubsectionsViaSymbols )
 
 import Outputable
 import NameEnv
@@ -175,7 +174,7 @@
 import Data.Set (Set)
 
 import HieAst           ( mkHieFile )
-import HieTypes         ( getAsts, hie_asts )
+import HieTypes         ( getAsts, hie_asts, hie_module )
 import HieBin           ( readHieFile, writeHieFile , hie_file_result)
 import HieDebug         ( diffFile, validateScopes )
 
@@ -428,7 +427,8 @@
             hs_env <- Hsc $ \e w -> return (e, w)
             liftIO $ do
               -- Validate Scopes
-              case validateScopes $ getAsts $ hie_asts hieFile of
+              let mdl = hie_module hieFile
+              case validateScopes mdl $ getAsts $ hie_asts hieFile of
                   [] -> putMsg dflags $ text "Got valid scopes"
                   xs -> do
                     putMsg dflags $ text "Got invalid scopes"
@@ -1426,7 +1426,7 @@
                             return a
                 rawcmms1 = Stream.mapM dump rawcmms0
 
-            (output_filename, (_stub_h_exists, stub_c_exists), foreign_fps)
+            (output_filename, (_stub_h_exists, stub_c_exists), foreign_fps, ())
                 <- {-# SCC "codeOutput" #-}
                   codeOutput dflags this_mod output_filename location
                   foreign_stubs foreign_files dependencies rawcmms1
@@ -1522,31 +1522,11 @@
 
         ppr_stream1 = Stream.mapM dump1 cmm_stream
 
-    -- We are building a single SRT for the entire module, so
-    -- we must thread it through all the procedures as we cps-convert them.
-    us <- mkSplitUniqSupply 'S'
-
-    -- When splitting, we generate one SRT per split chunk, otherwise
-    -- we generate one SRT for the whole module.
-    let
-     pipeline_stream
-      | gopt Opt_SplitSections dflags ||
-        osSubsectionsViaSymbols (platformOS (targetPlatform dflags))
-        = {-# SCC "cmmPipeline" #-}
-          let run_pipeline us cmmgroup = do
-                (_topSRT, cmmgroup) <-
-                  cmmPipeline hsc_env (emptySRT this_mod) cmmgroup
-                return (us, cmmgroup)
-
-          in do _ <- Stream.mapAccumL run_pipeline us ppr_stream1
-                return ()
-
-      | otherwise
-        = {-# SCC "cmmPipeline" #-}
-          let run_pipeline = cmmPipeline hsc_env
-          in void $ Stream.mapAccumL run_pipeline (emptySRT this_mod) ppr_stream1
+        pipeline_stream
+           = {-# SCC "cmmPipeline" #-}
+             let run_pipeline = cmmPipeline hsc_env
+             in void $ Stream.mapAccumL run_pipeline (emptySRT this_mod) ppr_stream1
 
-    let
         dump2 a = do dumpIfSet_dyn dflags Opt_D_dump_cmm
                         "Output Cmm" (ppr a)
                      return a
diff --git a/compiler/main/StaticPtrTable.hs b/compiler/main/StaticPtrTable.hs
--- a/compiler/main/StaticPtrTable.hs
+++ b/compiler/main/StaticPtrTable.hs
@@ -233,9 +233,10 @@
 
     -- Choose either 'Word64#' or 'Word#' to represent the arguments of the
     -- 'Fingerprint' data constructor.
-    mkWord64LitWordRep dflags
-      | platformWordSize (targetPlatform dflags) < 8 = mkWord64LitWord64
-      | otherwise = mkWordLit dflags . toInteger
+    mkWord64LitWordRep dflags =
+      case platformWordSize (targetPlatform dflags) of
+        PW4 -> mkWord64LitWord64
+        PW8 -> mkWordLit dflags . toInteger
 
     lookupIdHscEnv :: Name -> IO Id
     lookupIdHscEnv n = lookupTypeHscEnv hsc_env n >>=
diff --git a/compiler/main/SysTools/Tasks.hs b/compiler/main/SysTools/Tasks.hs
--- a/compiler/main/SysTools/Tasks.hs
+++ b/compiler/main/SysTools/Tasks.hs
@@ -16,14 +16,13 @@
 import GHC.Platform
 import Util
 
-import Data.Char
 import Data.List
 
 import System.IO
 import System.Process
 import GhcPrelude
 
-import LlvmCodeGen.Base (LlvmVersion (..), llvmVersionStr, supportedLlvmVersion)
+import LlvmCodeGen.Base (LlvmVersion, llvmVersionStr, supportedLlvmVersion, parseLlvmVersion)
 
 import SysTools.Process
 import SysTools.Info
@@ -209,7 +208,7 @@
       -- of the options they've specified. llc doesn't care what other
       -- options are specified when '-version' is used.
       args' = args ++ ["-version"]
-  ver <- catchIO (do
+  catchIO (do
               (pin, pout, perr, _) <- runInteractiveProcess pgm args'
                                               Nothing Nothing
               {- > llc -version
@@ -219,18 +218,12 @@
               -}
               hSetBinaryMode pout False
               _     <- hGetLine pout
-              vline <- dropWhile (not . isDigit) `fmap` hGetLine pout
-              v     <- case span (/= '.') vline of
-                        ("",_)  -> fail "no digits!"
-                        (x,"") -> return $ LlvmVersion (read x)
-                        (x,y) -> return $ LlvmVersionOld
-                                            (read x)
-                                            (read $ takeWhile isDigit $ drop 1 y)
-
+              vline <- hGetLine pout
+              let mb_ver = parseLlvmVersion vline
               hClose pin
               hClose pout
               hClose perr
-              return $ Just v
+              return mb_ver
             )
             (\err -> do
                 debugTraceMsg dflags 2
@@ -242,7 +235,6 @@
                           text ("Make sure you have installed LLVM " ++
                                 llvmVersionStr supportedLlvmVersion) ]
                 return Nothing)
-  return ver
 
 
 runLink :: DynFlags -> [Option] -> IO ()
diff --git a/compiler/nativeGen/AsmCodeGen.hs b/compiler/nativeGen/AsmCodeGen.hs
--- a/compiler/nativeGen/AsmCodeGen.hs
+++ b/compiler/nativeGen/AsmCodeGen.hs
@@ -157,14 +157,14 @@
 -}
 
 --------------------
-nativeCodeGen :: DynFlags -> Module -> ModLocation -> Handle -> UniqSupply
-              -> Stream IO RawCmmGroup ()
-              -> IO UniqSupply
+nativeCodeGen :: forall a . DynFlags -> Module -> ModLocation -> Handle -> UniqSupply
+              -> Stream IO RawCmmGroup a
+              -> IO a
 nativeCodeGen dflags this_mod modLoc h us cmms
  = let platform = targetPlatform dflags
        nCG' :: ( Outputable statics, Outputable instr
                , Outputable jumpDest, Instruction instr)
-            => NcgImpl statics instr jumpDest -> IO UniqSupply
+            => NcgImpl statics instr jumpDest -> IO a
        nCG' ncgImpl = nativeCodeGen' dflags this_mod modLoc ncgImpl h us cmms
    in case platformArch platform of
       ArchX86       -> nCG' (x86NcgImpl    dflags)
@@ -314,8 +314,8 @@
                -> NcgImpl statics instr jumpDest
                -> Handle
                -> UniqSupply
-               -> Stream IO RawCmmGroup ()
-               -> IO UniqSupply
+               -> Stream IO RawCmmGroup a
+               -> IO a
 nativeCodeGen' dflags this_mod modLoc ncgImpl h us cmms
  = do
         -- BufHandle is a performance hack.  We could hide it inside
@@ -323,9 +323,10 @@
         -- printDocs here (in order to do codegen in constant space).
         bufh <- newBufHandle h
         let ngs0 = NGS [] [] [] [] [] [] emptyUFM mapEmpty
-        (ngs, us') <- cmmNativeGenStream dflags this_mod modLoc ncgImpl bufh us
+        (ngs, us', a) <- cmmNativeGenStream dflags this_mod modLoc ncgImpl bufh us
                                          cmms ngs0
-        finishNativeGen dflags modLoc bufh us' ngs
+        _ <- finishNativeGen dflags modLoc bufh us' ngs
+        return a
 
 finishNativeGen :: Instruction instr
                 => DynFlags
@@ -346,7 +347,7 @@
 
         -- dump global NCG stats for graph coloring allocator
         let stats = concat (ngs_colorStats ngs)
-        when (not (null stats)) $ do
+        unless (null stats) $ do
 
           -- build the global register conflict graph
           let graphGlobal
@@ -369,7 +370,7 @@
 
         -- dump global NCG stats for linear allocator
         let linearStats = concat (ngs_linearStats ngs)
-        when (not (null linearStats)) $
+        unless (null linearStats) $
           dump_stats (Linear.pprStats (concat (ngs_natives ngs)) linearStats)
 
         -- write out the imports
@@ -386,20 +387,21 @@
               -> NcgImpl statics instr jumpDest
               -> BufHandle
               -> UniqSupply
-              -> Stream IO RawCmmGroup ()
+              -> Stream IO RawCmmGroup a
               -> NativeGenAcc statics instr
-              -> IO (NativeGenAcc statics instr, UniqSupply)
+              -> IO (NativeGenAcc statics instr, UniqSupply, a)
 
 cmmNativeGenStream dflags this_mod modLoc ncgImpl h us cmm_stream ngs
  = do r <- Stream.runStream cmm_stream
       case r of
-        Left () ->
+        Left a ->
           return (ngs { ngs_imports = reverse $ ngs_imports ngs
                       , ngs_natives = reverse $ ngs_natives ngs
                       , ngs_colorStats = reverse $ ngs_colorStats ngs
                       , ngs_linearStats = reverse $ ngs_linearStats ngs
                       },
-                  us)
+                  us,
+                  a)
         Right (cmms, cmm_stream') -> do
           (us', ngs'') <-
             withTiming (return dflags)
@@ -417,8 +419,9 @@
               -- Link native code information into debug blocks
               -- See Note [What is this unwinding business?] in Debug.
               let !ldbgs = cmmDebugLink (ngs_labels ngs') (ngs_unwinds ngs') ndbgs
-              dumpIfSet_dyn dflags Opt_D_dump_debug "Debug Infos"
-                (vcat $ map ppr ldbgs)
+              unless (null ldbgs) $
+                dumpIfSet_dyn dflags Opt_D_dump_debug "Debug Infos"
+                  (vcat $ map ppr ldbgs)
 
               -- Accumulate debug information for emission in finishNativeGen.
               let ngs'' = ngs' { ngs_debug = ngs_debug ngs' ++ ldbgs, ngs_labels = [] }
@@ -475,7 +478,7 @@
           map (pprNatCmmDecl ncgImpl) native
 
         -- force evaluation all this stuff to avoid space leaks
-        {-# SCC "seqString" #-} evaluate $ seqString (showSDoc dflags $ vcat $ map ppr imports)
+        {-# SCC "seqString" #-} evaluate $ seqList (showSDoc dflags $ vcat $ map ppr imports) ()
 
         let !labels' = if debugLevel dflags > 0
                        then cmmDebugLabels isMetaInstr native else []
@@ -492,9 +495,6 @@
                       , ngs_unwinds     = ngs_unwinds ngs `mapUnion` unwinds
                       }
         go us' cmms ngs' (count + 1)
-
-    seqString []            = ()
-    seqString (x:xs)        = x `seq` seqString xs
 
 
 emitNativeCode :: DynFlags -> BufHandle -> SDoc -> IO ()
diff --git a/compiler/nativeGen/BlockLayout.hs b/compiler/nativeGen/BlockLayout.hs
--- a/compiler/nativeGen/BlockLayout.hs
+++ b/compiler/nativeGen/BlockLayout.hs
@@ -4,9 +4,6 @@
 
 {-# LANGUAGE TypeFamilies, ScopedTypeVariables, CPP #-}
 
-{-# OPTIONS_GHC -fprof-auto #-}
---{-# OPTIONS_GHC -ddump-simpl -ddump-to-file -ddump-cmm #-}
-
 module BlockLayout
     ( sequenceTop )
 where
@@ -37,7 +34,6 @@
 --import Debug
 --import Debug.Trace
 import ListSetOps (removeDups)
-import PprCmm ()
 
 import OrdList
 import Data.List
diff --git a/compiler/nativeGen/CFG.hs b/compiler/nativeGen/CFG.hs
--- a/compiler/nativeGen/CFG.hs
+++ b/compiler/nativeGen/CFG.hs
@@ -56,7 +56,7 @@
 --import Debug
 --import OrdList
 --import Debug.Trace
-import PprCmm ()
+import PprCmm () -- For Outputable instances
 import qualified DynFlags as D
 
 import Data.List
diff --git a/compiler/nativeGen/Dwarf.hs b/compiler/nativeGen/Dwarf.hs
--- a/compiler/nativeGen/Dwarf.hs
+++ b/compiler/nativeGen/Dwarf.hs
@@ -116,7 +116,7 @@
           , pprHalf 3                          -- DWARF version
           , sectionOffset (ptext dwarfAbbrevLabel) (ptext dwarfAbbrevLabel)
                                                -- abbrevs offset
-          , text "\t.byte " <> ppr (platformWordSize plat) -- word size
+          , text "\t.byte " <> ppr (platformWordSizeInBytes plat) -- word size
           ]
 
 -- | Compilation unit footer, mainly establishing size of debug sections
diff --git a/compiler/nativeGen/Dwarf/Types.hs b/compiler/nativeGen/Dwarf/Types.hs
--- a/compiler/nativeGen/Dwarf/Types.hs
+++ b/compiler/nativeGen/Dwarf/Types.hs
@@ -224,7 +224,7 @@
 -- address table entry.
 pprDwarfARanges :: [DwarfARange] -> Unique -> SDoc
 pprDwarfARanges arngs unitU = sdocWithPlatform $ \plat ->
-  let wordSize = platformWordSize plat
+  let wordSize = platformWordSizeInBytes plat
       paddingSize = 4 :: Int
       -- header is 12 bytes long.
       -- entry is 8 bytes (32-bit platform) or 16 bytes (64-bit platform).
@@ -293,7 +293,7 @@
         length      = ppr cieEndLabel <> char '-' <> ppr cieStartLabel
         spReg       = dwarfGlobalRegNo plat Sp
         retReg      = dwarfReturnRegNo plat
-        wordSize    = platformWordSize plat
+        wordSize    = platformWordSizeInBytes plat
         pprInit :: (GlobalReg, Maybe UnwindExpr) -> SDoc
         pprInit (g, uw) = pprSetUnwind plat g (Nothing, uw)
 
@@ -454,9 +454,9 @@
 pprSetUnwind _    Sp (_, Just uw)
   = pprByte dW_CFA_def_cfa_expression $$ pprUnwindExpr False uw
 pprSetUnwind plat g  (_, Just (UwDeref (UwReg Sp o)))
-  | o < 0 && ((-o) `mod` platformWordSize plat) == 0 -- expected case
+  | o < 0 && ((-o) `mod` platformWordSizeInBytes plat) == 0 -- expected case
   = pprByte (dW_CFA_offset + dwarfGlobalRegNo plat g) $$
-    pprLEBWord (fromIntegral ((-o) `div` platformWordSize plat))
+    pprLEBWord (fromIntegral ((-o) `div` platformWordSizeInBytes plat))
   | otherwise
   = pprByte dW_CFA_offset_extended_sf $$
     pprLEBRegNo plat g $$
@@ -517,10 +517,9 @@
 wordAlign = sdocWithPlatform $ \plat ->
   text "\t.align " <> case platformOS plat of
     OSDarwin -> case platformWordSize plat of
-      8      -> text "3"
-      4      -> text "2"
-      _other -> error "wordAlign: Unsupported word size!"
-    _other   -> ppr (platformWordSize plat)
+      PW8 -> char '3'
+      PW4 -> char '2'
+    _other   -> ppr (platformWordSizeInBytes plat)
 
 -- | Assembly for a single byte of constant DWARF data
 pprByte :: Word8 -> SDoc
@@ -552,10 +551,8 @@
 pprWord :: SDoc -> SDoc
 pprWord s = (<> s) . sdocWithPlatform $ \plat ->
   case platformWordSize plat of
-    4 -> text "\t.long "
-    8 -> text "\t.quad "
-    n -> panic $ "pprWord: Unsupported target platform word length " ++
-                 show n ++ "!"
+    PW4 -> text "\t.long "
+    PW8 -> text "\t.quad "
 
 -- | Prints a number in "little endian base 128" format. The idea is
 -- to optimize for small numbers by stopping once all further bytes
diff --git a/compiler/nativeGen/PPC/Instr.hs b/compiler/nativeGen/PPC/Instr.hs
--- a/compiler/nativeGen/PPC/Instr.hs
+++ b/compiler/nativeGen/PPC/Instr.hs
@@ -98,7 +98,7 @@
     , STU fmt r0 (AddrRegReg sp tmp)
     ]
   where
-    fmt = intFormat $ widthFromBytes (platformWordSize platform)
+    fmt = intFormat $ widthFromBytes (platformWordSizeInBytes platform)
     zero = ImmInt 0
     tmp = tmpReg platform
     immAmount = ImmInt amount
diff --git a/compiler/nativeGen/PPC/Ppr.hs b/compiler/nativeGen/PPC/Ppr.hs
--- a/compiler/nativeGen/PPC/Ppr.hs
+++ b/compiler/nativeGen/PPC/Ppr.hs
@@ -27,7 +27,7 @@
 
 import BlockId
 import CLabel
-import PprCmmExpr ()
+import PprCmmExpr () -- For Outputable instances
 
 import Unique                ( pprUniqueAlways, getUnique )
 import GHC.Platform
diff --git a/compiler/nativeGen/RegAlloc/Graph/Main.hs b/compiler/nativeGen/RegAlloc/Graph/Main.hs
--- a/compiler/nativeGen/RegAlloc/Graph/Main.hs
+++ b/compiler/nativeGen/RegAlloc/Graph/Main.hs
@@ -310,7 +310,7 @@
         -- Add the reg-reg conflicts to the graph.
         let conflictBag         = unionManyBags conflictList
         let graph_conflict
-                = foldrBag graphAddConflictSet Color.initGraph conflictBag
+                = foldr graphAddConflictSet Color.initGraph conflictBag
 
         -- Add the coalescences edges to the graph.
         let moveBag
@@ -318,7 +318,7 @@
                             (unionManyBags moveList)
 
         let graph_coalesce
-                = foldrBag graphAddCoalesce graph_conflict moveBag
+                = foldr graphAddCoalesce graph_conflict moveBag
 
         return  graph_coalesce
 
diff --git a/compiler/nativeGen/RegAlloc/Graph/Stats.hs b/compiler/nativeGen/RegAlloc/Graph/Stats.hs
--- a/compiler/nativeGen/RegAlloc/Graph/Stats.hs
+++ b/compiler/nativeGen/RegAlloc/Graph/Stats.hs
@@ -28,7 +28,6 @@
 import Reg
 import TargetReg
 
-import PprCmm()
 import Outputable
 import UniqFM
 import UniqSet
diff --git a/compiler/nativeGen/RegAlloc/Liveness.hs b/compiler/nativeGen/RegAlloc/Liveness.hs
--- a/compiler/nativeGen/RegAlloc/Liveness.hs
+++ b/compiler/nativeGen/RegAlloc/Liveness.hs
@@ -45,7 +45,6 @@
 import Hoopl.Collections
 import Hoopl.Label
 import Cmm hiding (RegSet, emptyRegSet)
-import PprCmm()
 
 import Digraph
 import DynFlags
diff --git a/compiler/nativeGen/SPARC/CodeGen.hs b/compiler/nativeGen/SPARC/CodeGen.hs
--- a/compiler/nativeGen/SPARC/CodeGen.hs
+++ b/compiler/nativeGen/SPARC/CodeGen.hs
@@ -31,7 +31,6 @@
 import SPARC.CodeGen.Gen64
 import SPARC.CodeGen.Gen32
 import SPARC.CodeGen.Base
-import SPARC.Ppr        ()
 import SPARC.Instr
 import SPARC.Imm
 import SPARC.AddrMode
diff --git a/compiler/nativeGen/SPARC/CodeGen/Base.hs b/compiler/nativeGen/SPARC/CodeGen/Base.hs
--- a/compiler/nativeGen/SPARC/CodeGen/Base.hs
+++ b/compiler/nativeGen/SPARC/CodeGen/Base.hs
@@ -25,7 +25,7 @@
 import CodeGen.Platform
 import DynFlags
 import Cmm
-import PprCmmExpr ()
+import PprCmmExpr () -- For Outputable instances
 import GHC.Platform
 
 import Outputable
diff --git a/compiler/nativeGen/SPARC/CodeGen/Expand.hs b/compiler/nativeGen/SPARC/CodeGen/Expand.hs
--- a/compiler/nativeGen/SPARC/CodeGen/Expand.hs
+++ b/compiler/nativeGen/SPARC/CodeGen/Expand.hs
@@ -11,7 +11,6 @@
 import SPARC.Imm
 import SPARC.AddrMode
 import SPARC.Regs
-import SPARC.Ppr        ()
 import Instruction
 import Reg
 import Format
diff --git a/compiler/nativeGen/SPARC/CodeGen/Gen64.hs b/compiler/nativeGen/SPARC/CodeGen/Gen64.hs
--- a/compiler/nativeGen/SPARC/CodeGen/Gen64.hs
+++ b/compiler/nativeGen/SPARC/CodeGen/Gen64.hs
@@ -16,7 +16,7 @@
 import SPARC.AddrMode
 import SPARC.Imm
 import SPARC.Instr
-import SPARC.Ppr()
+-- import SPARC.Ppr()
 import NCGMonad
 import Instruction
 import Format
diff --git a/compiler/nativeGen/SPARC/CodeGen/Sanity.hs b/compiler/nativeGen/SPARC/CodeGen/Sanity.hs
--- a/compiler/nativeGen/SPARC/CodeGen/Sanity.hs
+++ b/compiler/nativeGen/SPARC/CodeGen/Sanity.hs
@@ -9,7 +9,7 @@
 import GhcPrelude
 
 import SPARC.Instr
-import SPARC.Ppr        ()
+import SPARC.Ppr        () -- For Outputable instances
 import Instruction
 
 import Cmm
diff --git a/compiler/nativeGen/SPARC/Ppr.hs b/compiler/nativeGen/SPARC/Ppr.hs
--- a/compiler/nativeGen/SPARC/Ppr.hs
+++ b/compiler/nativeGen/SPARC/Ppr.hs
@@ -39,7 +39,7 @@
 import PprBase
 
 import Cmm hiding (topInfoTable)
-import PprCmm()
+import PprCmm() -- For Outputable instances
 import BlockId
 import CLabel
 import Hoopl.Label
diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs
--- a/compiler/nativeGen/X86/CodeGen.hs
+++ b/compiler/nativeGen/X86/CodeGen.hs
@@ -38,9 +38,6 @@
 import X86.Regs
 import X86.RegInfo
 
---TODO: Remove - Just for development/debugging
-import X86.Ppr()
-
 import CodeGen.Platform
 import CPrim
 import Debug            ( DebugBlock(..), UnwindPoint(..), UnwindTable
@@ -60,7 +57,6 @@
 import BasicTypes
 import BlockId
 import Module           ( primUnitId )
-import PprCmm           ()
 import CmmUtils
 import CmmSwitch
 import Cmm
diff --git a/compiler/rename/RnBinds.hs b/compiler/rename/RnBinds.hs
--- a/compiler/rename/RnBinds.hs
+++ b/compiler/rename/RnBinds.hs
@@ -853,7 +853,7 @@
              -- for instance decls too
 
        -- Rename the bindings LHSs
-       ; binds' <- foldrBagM (rnMethodBindLHS is_cls_decl cls) emptyBag binds
+       ; binds' <- foldrM (rnMethodBindLHS is_cls_decl cls) emptyBag binds
 
        -- Rename the pragmas and signatures
        -- Annoyingly the type variables /are/ in scope for signatures, but
@@ -875,7 +875,7 @@
        ; scoped_tvs  <- xoptM LangExt.ScopedTypeVariables
        ; (binds'', bind_fvs) <- maybe_extend_tyvar_env scoped_tvs $
               do { binds_w_dus <- mapBagM (rnLBind (mkScopedTvFn other_sigs')) binds'
-                 ; let bind_fvs = foldrBag (\(_,_,fv1) fv2 -> fv1 `plusFV` fv2)
+                 ; let bind_fvs = foldr (\(_,_,fv1) fv2 -> fv1 `plusFV` fv2)
                                            emptyFVs binds_w_dus
                  ; return (mapBag fstOf3 binds_w_dus, bind_fvs) }
 
diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs
--- a/compiler/rename/RnSource.hs
+++ b/compiler/rename/RnSource.hs
@@ -2135,7 +2135,7 @@
    ; setEnvs (final_gbl_env, lcl_env) (thing pat_syn_bndrs) }
   where
     new_ps :: HsValBinds GhcPs -> TcM [(Name, [FieldLabel])]
-    new_ps (ValBinds _ binds _) = foldrBagM new_ps' [] binds
+    new_ps (ValBinds _ binds _) = foldrM new_ps' [] binds
     new_ps _ = panic "new_ps"
 
     new_ps' :: LHsBindLR GhcPs GhcPs
diff --git a/compiler/simplCore/FloatOut.hs b/compiler/simplCore/FloatOut.hs
--- a/compiler/simplCore/FloatOut.hs
+++ b/compiler/simplCore/FloatOut.hs
@@ -629,7 +629,7 @@
 
 addTopFloatPairs :: Bag CoreBind -> [(Id,CoreExpr)] -> [(Id,CoreExpr)]
 addTopFloatPairs float_bag prs
-  = foldrBag add prs float_bag
+  = foldr add prs float_bag
   where
     add (NonRec b r) prs  = (b,r):prs
     add (Rec prs1)   prs2 = prs1 ++ prs2
@@ -673,7 +673,7 @@
 
 install :: Bag FloatBind -> CoreExpr -> CoreExpr
 install defn_groups expr
-  = foldrBag wrapFloat expr defn_groups
+  = foldr wrapFloat expr defn_groups
 
 partitionByLevel
         :: Level                -- Partitioning level
diff --git a/compiler/simplStg/UnariseStg.hs b/compiler/simplStg/UnariseStg.hs
--- a/compiler/simplStg/UnariseStg.hs
+++ b/compiler/simplStg/UnariseStg.hs
@@ -188,6 +188,8 @@
     `StgCmmEnv.NonVoid`, for example.
 
   * Alt binders (binders in patterns) are always non-void.
+
+  * Binders always have zero (for void arguments) or one PrimRep.
 -}
 
 {-# LANGUAGE CPP, TupleSections #-}
diff --git a/compiler/specialise/Specialise.hs b/compiler/specialise/Specialise.hs
--- a/compiler/specialise/Specialise.hs
+++ b/compiler/specialise/Specialise.hs
@@ -2181,7 +2181,7 @@
 
 callInfoFVs :: CallInfoSet -> VarSet
 callInfoFVs (CIS _ call_info) =
-  foldrBag (\(CI { ci_fvs = fv }) vs -> unionVarSet fv vs) emptyVarSet call_info
+  foldr (\(CI { ci_fvs = fv }) vs -> unionVarSet fv vs) emptyVarSet call_info
 
 computeArity :: [SpecArg] -> Int
 computeArity = length . filter isValueArg . dropWhileEndLE isUnspecArg
@@ -2350,7 +2350,7 @@
 
 -----------------------------
 _dictBindBndrs :: Bag DictBind -> [Id]
-_dictBindBndrs dbs = foldrBag ((++) . bindersOf . fst) [] dbs
+_dictBindBndrs dbs = foldr ((++) . bindersOf . fst) [] dbs
 
 -- | Construct a 'DictBind' from a 'CoreBind'
 mkDB :: CoreBind -> DictBind
@@ -2389,7 +2389,7 @@
 recWithDumpedDicts pairs dbs
   = (Rec bindings, fvs)
   where
-    (bindings, fvs) = foldrBag add
+    (bindings, fvs) = foldr add
                                ([], emptyVarSet)
                                (dbs `snocBag` mkDB (Rec pairs))
     add (NonRec b r, fvs') (pairs, fvs) =
@@ -2413,13 +2413,13 @@
 
 wrapDictBinds :: Bag DictBind -> [CoreBind] -> [CoreBind]
 wrapDictBinds dbs binds
-  = foldrBag add binds dbs
+  = foldr add binds dbs
   where
     add (bind,_) binds = bind : binds
 
 wrapDictBindsE :: Bag DictBind -> CoreExpr -> CoreExpr
 wrapDictBindsE dbs expr
-  = foldrBag add expr dbs
+  = foldr add expr dbs
   where
     add (bind,_) expr = Let bind expr
 
@@ -2478,7 +2478,7 @@
 filterCalls (CIS fn call_bag) dbs
   = filter ok_call (bagToList call_bag)
   where
-    dump_set = foldlBag go (unitVarSet fn) dbs
+    dump_set = foldl' go (unitVarSet fn) dbs
       -- This dump-set could also be computed by splitDictBinds
       --   (_,_,dump_set) = splitDictBinds dbs {fn}
       -- But this variant is shorter
@@ -2498,8 +2498,8 @@
 --   * free_dbs does not depend on bndrs
 --   * dump_set = bndrs `union` bndrs(dump_dbs)
 splitDictBinds dbs bndr_set
-   = foldlBag split_db (emptyBag, emptyBag, bndr_set) dbs
-                -- Important that it's foldl not foldr;
+   = foldl' split_db (emptyBag, emptyBag, bndr_set) dbs
+                -- Important that it's foldl' not foldr;
                 -- we're accumulating the set of dumped ids in dump_set
    where
     split_db (free_dbs, dump_dbs, dump_idset) db@(bind, fvs)
diff --git a/compiler/stgSyn/CoreToStg.hs b/compiler/stgSyn/CoreToStg.hs
--- a/compiler/stgSyn/CoreToStg.hs
+++ b/compiler/stgSyn/CoreToStg.hs
@@ -268,7 +268,7 @@
 
         bind = StgTopLifted $ StgNonRec id stg_rhs
     in
-    assertConsistentCaInfo dflags id bind (ppr bind)
+    assertConsistentCafInfo dflags id bind (ppr bind)
       -- NB: previously the assertion printed 'rhs' and 'bind'
       --     as well as 'id', but that led to a black hole
       --     where printing the assertion error tripped the
@@ -296,17 +296,17 @@
 
         bind = StgTopLifted $ StgRec (zip binders stg_rhss)
     in
-    assertConsistentCaInfo dflags (head binders) bind (ppr binders)
+    assertConsistentCafInfo dflags (head binders) bind (ppr binders)
     (env', ccs', bind)
 
 -- | CAF consistency issues will generally result in segfaults and are quite
 -- difficult to debug (see #16846). We enable checking of the
 -- 'consistentCafInfo' invariant with @-dstg-lint@ to increase the chance that
 -- we catch these issues.
-assertConsistentCaInfo :: DynFlags -> Id -> StgTopBinding -> SDoc -> a -> a
-assertConsistentCaInfo dflags id bind err_doc result
+assertConsistentCafInfo :: DynFlags -> Id -> StgTopBinding -> SDoc -> a -> a
+assertConsistentCafInfo dflags id bind err_doc result
   | gopt Opt_DoStgLinting dflags || debugIsOn
-  , not $ consistentCafInfo id bind = pprPanic "assertConsistentCaInfo" err_doc
+  , not $ consistentCafInfo id bind = pprPanic "assertConsistentCafInfo" err_doc
   | otherwise = result
 
 -- Assertion helper: this checks that the CafInfo on the Id matches
@@ -384,11 +384,11 @@
   -- We lower 'LitRubbish' to @()@ here, which is much easier than doing it in
   -- a STG to Cmm pass.
   = coreToStgExpr (Var unitDataConId)
-coreToStgExpr (Var v)      = coreToStgApp Nothing v               [] []
-coreToStgExpr (Coercion _) = coreToStgApp Nothing coercionTokenId [] []
+coreToStgExpr (Var v)      = coreToStgApp v               [] []
+coreToStgExpr (Coercion _) = coreToStgApp coercionTokenId [] []
 
 coreToStgExpr expr@(App _ _)
-  = coreToStgApp Nothing f args ticks
+  = coreToStgApp f args ticks
   where
     (f, args, ticks) = myCollectArgs expr
 
@@ -502,18 +502,11 @@
 -- Applications
 -- ---------------------------------------------------------------------------
 
-coreToStgApp
-         :: Maybe UpdateFlag            -- Just upd <=> this application is
-                                        -- the rhs of a thunk binding
-                                        --      x = [...] \upd [] -> the_app
-                                        -- with specified update flag
-        -> Id                           -- Function
-        -> [CoreArg]                    -- Arguments
-        -> [Tickish Id]                 -- Debug ticks
-        -> CtsM StgExpr
-
-
-coreToStgApp _ f args ticks = do
+coreToStgApp :: Id            -- Function
+             -> [CoreArg]     -- Arguments
+             -> [Tickish Id]  -- Debug ticks
+             -> CtsM StgExpr
+coreToStgApp f args ticks = do
     (args', ticks') <- coreToStgArgs args
     how_bound <- lookupVarCts f
 
diff --git a/compiler/stgSyn/StgSyn.hs b/compiler/stgSyn/StgSyn.hs
--- a/compiler/stgSyn/StgSyn.hs
+++ b/compiler/stgSyn/StgSyn.hs
@@ -1,7 +1,8 @@
 {-
 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 
-\section[StgSyn]{Shared term graph (STG) syntax for spineless-tagless code generation}
+Shared term graph (STG) syntax for spineless-tagless code generation
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
 This data type represents programs just before code generation (conversion to
 @Cmm@): basically, what we have is a stylised form of @CoreSyntax@, the style
@@ -67,7 +68,6 @@
 import Data.List   ( intersperse )
 import DataCon
 import DynFlags
-import FastString
 import ForeignCall ( ForeignCall )
 import Id
 import IdInfo      ( mayHaveCafRefs )
@@ -89,14 +89,13 @@
 {-
 ************************************************************************
 *                                                                      *
-\subsection{@GenStgBinding@}
+GenStgBinding
 *                                                                      *
 ************************************************************************
 
-As usual, expressions are interesting; other things are boring. Here
-are the boring things [except note the @GenStgRhs@], parameterised
-with respect to binder and occurrence information (just as in
-@CoreSyn@):
+As usual, expressions are interesting; other things are boring. Here are the
+boring things (except note the @GenStgRhs@), parameterised with respect to
+binder and occurrence information (just as in @CoreSyn@):
 -}
 
 -- | A top-level binding.
@@ -112,7 +111,7 @@
 {-
 ************************************************************************
 *                                                                      *
-\subsection{@StgArg@}
+StgArg
 *                                                                      *
 ************************************************************************
 -}
@@ -121,8 +120,8 @@
   = StgVarArg  Id
   | StgLitArg  Literal
 
--- | Does this constructor application refer to
--- anything in a different *Windows* DLL?
+-- | Does this constructor application refer to anything in a different
+-- *Windows* DLL?
 -- If so, we can't allocate it statically
 isDllConApp :: DynFlags -> Module -> DataCon -> [StgArg] -> Bool
 isDllConApp dflags this_mod con args
@@ -137,17 +136,22 @@
                              && isDllName dflags this_mod (idName v)
     is_dll_arg _             = False
 
--- True of machine addresses; these are the things that don't
--- work across DLLs. The key point here is that VoidRep comes
--- out False, so that a top level nullary GADT constructor is
--- False for isDllConApp
+-- True of machine addresses; these are the things that don't work across DLLs.
+-- The key point here is that VoidRep comes out False, so that a top level
+-- nullary GADT constructor is False for isDllConApp
+--
 --    data T a where
 --      T1 :: T Int
+--
 -- gives
+--
 --    T1 :: forall a. (a~Int) -> T a
+--
 -- and hence the top-level binding
+--
 --    $WT1 :: T Int
 --    $WT1 = T1 Int (Coercion (Refl Int))
+--
 -- The coercion argument here gets VoidRep
 isAddrRep :: PrimRep -> Bool
 isAddrRep AddrRep     = True
@@ -191,26 +195,25 @@
 {-
 ************************************************************************
 *                                                                      *
-\subsection{STG expressions}
+STG expressions
 *                                                                      *
 ************************************************************************
 
-The @GenStgExpr@ data type is parameterised on binder and occurrence
-info, as before.
+The @GenStgExpr@ data type is parameterised on binder and occurrence info, as
+before.
 
 ************************************************************************
 *                                                                      *
-\subsubsection{@GenStgExpr@ application}
+GenStgExpr
 *                                                                      *
 ************************************************************************
 
-An application is of a function to a list of atoms [not expressions].
-Operationally, we want to push the arguments on the stack and call the
-function. (If the arguments were expressions, we would have to build
-their closures first.)
+An application is of a function to a list of atoms (not expressions).
+Operationally, we want to push the arguments on the stack and call the function.
+(If the arguments were expressions, we would have to build their closures
+first.)
 
-There is no constructor for a lone variable; it would appear as
-@StgApp var []@.
+There is no constructor for a lone variable; it would appear as @StgApp var []@.
 -}
 
 data GenStgExpr pass
@@ -221,18 +224,18 @@
 {-
 ************************************************************************
 *                                                                      *
-\subsubsection{@StgConApp@ and @StgPrimApp@---saturated applications}
+StgConApp and StgPrimApp --- saturated applications
 *                                                                      *
 ************************************************************************
 
-There are specialised forms of application, for constructors,
-primitives, and literals.
+There are specialised forms of application, for constructors, primitives, and
+literals.
 -}
 
   | StgLit      Literal
 
         -- StgConApp is vital for returning unboxed tuples or sums
-        -- which can't be let-bound first
+        -- which can't be let-bound
   | StgConApp   DataCon
                 [StgArg] -- Saturated
                 [Type]   -- See Note [Types in StgConApp] in UnariseStg
@@ -246,13 +249,13 @@
 {-
 ************************************************************************
 *                                                                      *
-\subsubsection{@StgLam@}
+StgLam
 *                                                                      *
 ************************************************************************
 
-StgLam is used *only* during CoreToStg's work. Before CoreToStg has
-finished it encodes (\x -> e) as (let f = \x -> e in f)
-TODO: Encode this via an extension to GenStgExpr à la TTG.
+StgLam is used *only* during CoreToStg's work. Before CoreToStg has finished it
+encodes (\x -> e) as (let f = \x -> e in f) TODO: Encode this via an extension
+to GenStgExpr à la TTG.
 -}
 
   | StgLam
@@ -262,7 +265,7 @@
 {-
 ************************************************************************
 *                                                                      *
-\subsubsection{@GenStgExpr@: case-expressions}
+GenStgExpr: case-expressions
 *                                                                      *
 ************************************************************************
 
@@ -280,94 +283,75 @@
 {-
 ************************************************************************
 *                                                                      *
-\subsubsection{@GenStgExpr@: @let(rec)@-expressions}
+GenStgExpr: let(rec)-expressions
 *                                                                      *
 ************************************************************************
 
-The various forms of let(rec)-expression encode most of the
-interesting things we want to do.
-\begin{enumerate}
-\item
-\begin{verbatim}
-let-closure x = [free-vars] [args] expr
-in e
-\end{verbatim}
-is equivalent to
-\begin{verbatim}
-let x = (\free-vars -> \args -> expr) free-vars
-\end{verbatim}
-\tr{args} may be empty (and is for most closures).  It isn't under
-circumstances like this:
-\begin{verbatim}
-let x = (\y -> y+z)
-\end{verbatim}
-This gets mangled to
-\begin{verbatim}
-let-closure x = [z] [y] (y+z)
-\end{verbatim}
-The idea is that we compile code for @(y+z)@ in an environment in which
-@z@ is bound to an offset from \tr{Node}, and @y@ is bound to an
-offset from the stack pointer.
+The various forms of let(rec)-expression encode most of the interesting things
+we want to do.
 
-(A let-closure is an @StgLet@ with a @StgRhsClosure@ RHS.)
+-   let-closure x = [free-vars] [args] expr in e
 
-\item
-\begin{verbatim}
-let-constructor x = Constructor [args]
-in e
-\end{verbatim}
+  is equivalent to
 
-(A let-constructor is an @StgLet@ with a @StgRhsCon@ RHS.)
+    let x = (\free-vars -> \args -> expr) free-vars
 
-\item
-Letrec-expressions are essentially the same deal as
-let-closure/let-constructor, so we use a common structure and
-distinguish between them with an @is_recursive@ boolean flag.
+  @args@ may be empty (and is for most closures). It isn't under circumstances
+  like this:
 
-\item
-\begin{verbatim}
-let-unboxed u = an arbitrary arithmetic expression in unboxed values
-in e
-\end{verbatim}
-All the stuff on the RHS must be fully evaluated.
-No function calls either!
+    let x = (\y -> y+z)
 
-(We've backed away from this toward case-expressions with
-suitably-magical alts ...)
+  This gets mangled to
 
-\item
-~[Advanced stuff here! Not to start with, but makes pattern matching
-generate more efficient code.]
+    let-closure x = [z] [y] (y+z)
 
-\begin{verbatim}
-let-escapes-not fail = expr
-in e'
-\end{verbatim}
-Here the idea is that @e'@ guarantees not to put @fail@ in a data structure,
-or pass it to another function. All @e'@ will ever do is tail-call @fail@.
-Rather than build a closure for @fail@, all we need do is to record the stack
-level at the moment of the @let-escapes-not@; then entering @fail@ is just
-a matter of adjusting the stack pointer back down to that point and entering
-the code for it.
+  The idea is that we compile code for @(y+z)@ in an environment in which @z@ is
+  bound to an offset from Node, and `y` is bound to an offset from the stack
+  pointer.
 
-Another example:
-\begin{verbatim}
-f x y = let z = huge-expression in
-        if y==1 then z else
-        if y==2 then z else
-        1
-\end{verbatim}
+  (A let-closure is an @StgLet@ with a @StgRhsClosure@ RHS.)
 
-(A let-escapes-not is an @StgLetNoEscape@.)
+-   let-constructor x = Constructor [args] in e
 
-\item
-We may eventually want:
-\begin{verbatim}
-let-literal x = Literal
-in e
-\end{verbatim}
-\end{enumerate}
+  (A let-constructor is an @StgLet@ with a @StgRhsCon@ RHS.)
 
+- Letrec-expressions are essentially the same deal as let-closure/
+  let-constructor, so we use a common structure and distinguish between them
+  with an @is_recursive@ boolean flag.
+
+-   let-unboxed u = <an arbitrary arithmetic expression in unboxed values> in e
+
+  All the stuff on the RHS must be fully evaluated. No function calls either!
+
+  (We've backed away from this toward case-expressions with suitably-magical
+  alts ...)
+
+- Advanced stuff here! Not to start with, but makes pattern matching generate
+  more efficient code.
+
+    let-escapes-not fail = expr
+    in e'
+
+  Here the idea is that @e'@ guarantees not to put @fail@ in a data structure,
+  or pass it to another function. All @e'@ will ever do is tail-call @fail@.
+  Rather than build a closure for @fail@, all we need do is to record the stack
+  level at the moment of the @let-escapes-not@; then entering @fail@ is just a
+  matter of adjusting the stack pointer back down to that point and entering the
+  code for it.
+
+  Another example:
+
+    f x y = let z = huge-expression in
+            if y==1 then z else
+            if y==2 then z else
+            1
+
+  (A let-escapes-not is an @StgLetNoEscape@.)
+
+- We may eventually want:
+
+    let-literal x = Literal in e
+
 And so the code for let(rec)-things:
 -}
 
@@ -382,11 +366,11 @@
         (GenStgExpr pass)       -- body
 
 {-
-%************************************************************************
-%*                                                                      *
-\subsubsection{@GenStgExpr@: @hpc@, @scc@ and other debug annotations}
-%*                                                                      *
-%************************************************************************
+*************************************************************************
+*                                                                      *
+GenStgExpr: hpc, scc and other debug annotations
+*                                                                      *
+*************************************************************************
 
 Finally for @hpc@ expressions we introduce a new STG construct.
 -}
@@ -400,12 +384,12 @@
 {-
 ************************************************************************
 *                                                                      *
-\subsection{STG right-hand sides}
+STG right-hand sides
 *                                                                      *
 ************************************************************************
 
-Here's the rest of the interesting stuff for @StgLet@s; the first
-flavour is for closures:
+Here's the rest of the interesting stuff for @StgLet@s; the first flavour is for
+closures:
 -}
 
 data GenStgRhs pass
@@ -420,18 +404,19 @@
 
 {-
 An example may be in order.  Consider:
-\begin{verbatim}
-let t = \x -> \y -> ... x ... y ... p ... q in e
-\end{verbatim}
+
+  let t = \x -> \y -> ... x ... y ... p ... q in e
+
 Pulling out the free vars and stylising somewhat, we get the equivalent:
-\begin{verbatim}
-let t = (\[p,q] -> \[x,y] -> ... x ... y ... p ...q) p q
-\end{verbatim}
-Stg-operationally, the @[x,y]@ are on the stack, the @[p,q]@ are
-offsets from @Node@ into the closure, and the code ptr for the closure
-will be exactly that in parentheses above.
 
-The second flavour of right-hand-side is for constructors (simple but important):
+  let t = (\[p,q] -> \[x,y] -> ... x ... y ... p ...q) p q
+
+Stg-operationally, the @[x,y]@ are on the stack, the @[p,q]@ are offsets from
+@Node@ into the closure, and the code ptr for the closure will be exactly that
+in parentheses above.
+
+The second flavour of right-hand-side is for constructors (simple but
+important):
 -}
 
   | StgRhsCon
@@ -569,20 +554,19 @@
 {-
 ************************************************************************
 *                                                                      *
-\subsection[Stg-case-alternatives]{STG case alternatives}
+STG case alternatives
 *                                                                      *
 ************************************************************************
 
 Very like in @CoreSyntax@ (except no type-world stuff).
 
-The type constructor is guaranteed not to be abstract; that is, we can
-see its representation. This is important because the code generator
-uses it to determine return conventions etc. But it's not trivial
-where there's a module loop involved, because some versions of a type
-constructor might not have all the constructors visible. So
-mkStgAlgAlts (in CoreToStg) ensures that it gets the TyCon from the
-constructors or literals (which are guaranteed to have the Real McCoy)
-rather than from the scrutinee type.
+The type constructor is guaranteed not to be abstract; that is, we can see its
+representation. This is important because the code generator uses it to
+determine return conventions etc. But it's not trivial where there's a module
+loop involved, because some versions of a type constructor might not have all
+the constructors visible. So mkStgAlgAlts (in CoreToStg) ensures that it gets
+the TyCon from the constructors or literals (which are guaranteed to have the
+Real McCoy) rather than from the scrutinee type.
 -}
 
 type GenStgAlt pass
@@ -601,7 +585,7 @@
 {-
 ************************************************************************
 *                                                                      *
-\subsection[Stg]{The Plain STG parameterisation}
+The Plain STG parameterisation
 *                                                                      *
 ************************************************************************
 
@@ -648,17 +632,16 @@
 
 ************************************************************************
 *                                                                      *
-\subsubsection[UpdateFlag-datatype]{@UpdateFlag@}
+UpdateFlag
 *                                                                      *
 ************************************************************************
 
 This is also used in @LambdaFormInfo@ in the @ClosureInfo@ module.
 
-A @ReEntrant@ closure may be entered multiple times, but should not be
-updated or blackholed. An @Updatable@ closure should be updated after
-evaluation (and may be blackholed during evaluation). A @SingleEntry@
-closure will only be entered once, and so need not be updated but may
-safely be blackholed.
+A @ReEntrant@ closure may be entered multiple times, but should not be updated
+or blackholed. An @Updatable@ closure should be updated after evaluation (and
+may be blackholed during evaluation). A @SingleEntry@ closure will only be
+entered once, and so need not be updated but may safely be blackholed.
 -}
 
 data UpdateFlag = ReEntrant | Updatable | SingleEntry
@@ -677,13 +660,12 @@
 {-
 ************************************************************************
 *                                                                      *
-\subsubsection{StgOp}
+StgOp
 *                                                                      *
 ************************************************************************
 
-An StgOp allows us to group together PrimOps and ForeignCalls.
-It's quite useful to move these around together, notably
-in StgOpApp and COpStmt.
+An StgOp allows us to group together PrimOps and ForeignCalls. It's quite useful
+to move these around together, notably in StgOpApp and COpStmt.
 -}
 
 data StgOp
@@ -700,12 +682,12 @@
 {-
 ************************************************************************
 *                                                                      *
-\subsection[Stg-pretty-printing]{Pretty-printing}
+Pretty-printing
 *                                                                      *
 ************************************************************************
 
-Robin Popplestone asked for semi-colon separators on STG binds; here's
-hoping he likes terminators instead...  Ditto for case alternatives.
+Robin Popplestone asked for semi-colon separators on STG binds; here's hoping he
+likes terminators instead...  Ditto for case alternatives.
 -}
 
 type OutputablePass pass =
@@ -876,15 +858,6 @@
 
 pprStgRhs :: OutputablePass pass => GenStgRhs pass -> SDoc
 
--- special case
-pprStgRhs (StgRhsClosure ext cc upd_flag [{-no args-}] (StgApp func []))
-  = sdocWithDynFlags $ \dflags ->
-    hsep [ ppr cc,
-           if not $ gopt Opt_SuppressStgExts dflags
-             then ppr ext else empty,
-           text " \\", ppr upd_flag, ptext (sLit " [] "), ppr func ]
-
--- general case
 pprStgRhs (StgRhsClosure ext cc upd_flag args body)
   = sdocWithDynFlags $ \dflags ->
     hang (hsep [if gopt Opt_SccProfilingOn dflags then ppr cc else empty,
diff --git a/compiler/typecheck/TcClassDcl.hs b/compiler/typecheck/TcClassDcl.hs
--- a/compiler/typecheck/TcClassDcl.hs
+++ b/compiler/typecheck/TcClassDcl.hs
@@ -369,7 +369,7 @@
                 -- site of the method binder, and any inline or
                 -- specialisation pragmas
 findMethodBind sel_name binds prag_fn
-  = foldlBag mplus Nothing (mapBag f binds)
+  = foldl' mplus Nothing (mapBag f binds)
   where
     prags    = lookupPragEnv prag_fn sel_name
 
diff --git a/compiler/typecheck/TcFlatten.hs b/compiler/typecheck/TcFlatten.hs
--- a/compiler/typecheck/TcFlatten.hs
+++ b/compiler/typecheck/TcFlatten.hs
@@ -29,6 +29,7 @@
 import Bag
 import Control.Monad
 import MonadUtils    ( zipWith3M )
+import Data.Foldable ( foldrM )
 
 import Control.Arrow ( first )
 
@@ -1690,11 +1691,11 @@
          --                 ==> (flatten) [W] F alpha ~ fmv, [W] alpha ~ [fmv]
          --                 ==> (unify)   [W] F [fmv] ~ fmv
          -- See Note [Unflatten using funeqs first]
-      ; funeqs <- foldrBagM unflatten_funeq emptyCts funeqs
+      ; funeqs <- foldrM unflatten_funeq emptyCts funeqs
       ; traceTcS "Unflattening 1" $ braces (pprCts funeqs)
 
           -- Step 2: unify the tv_eqs, if possible
-      ; tv_eqs  <- foldrBagM (unflatten_eq tclvl) emptyCts tv_eqs
+      ; tv_eqs  <- foldrM (unflatten_eq tclvl) emptyCts tv_eqs
       ; traceTcS "Unflattening 2" $ braces (pprCts tv_eqs)
 
           -- Step 3: fill any remaining fmvs with fresh unification variables
@@ -1702,7 +1703,7 @@
       ; traceTcS "Unflattening 3" $ braces (pprCts funeqs)
 
           -- Step 4: remove any tv_eqs that look like ty ~ ty
-      ; tv_eqs <- foldrBagM finalise_eq emptyCts tv_eqs
+      ; tv_eqs <- foldrM finalise_eq emptyCts tv_eqs
 
       ; let all_flat = tv_eqs `andCts` funeqs
       ; traceTcS "Unflattening done" $ braces (pprCts all_flat)
diff --git a/compiler/typecheck/TcGenDeriv.hs b/compiler/typecheck/TcGenDeriv.hs
--- a/compiler/typecheck/TcGenDeriv.hs
+++ b/compiler/typecheck/TcGenDeriv.hs
@@ -1973,11 +1973,11 @@
   splitDerivAuxBind (DerivAuxBind x) = Left x
   splitDerivAuxBind  x               = Right x
 
-  rm_dups = foldrBag dup_check emptyBag
+  rm_dups = foldr dup_check emptyBag
   dup_check a b = if anyBag (== a) b then b else consBag a b
 
   genAuxBinds' :: BagDerivStuff -> SeparateBagsDerivStuff
-  genAuxBinds' = foldrBag f ( mapBag (genAuxBindSpec dflags loc) (rm_dups b1)
+  genAuxBinds' = foldr f ( mapBag (genAuxBindSpec dflags loc) (rm_dups b1)
                             , emptyBag )
   f :: DerivStuff -> SeparateBagsDerivStuff -> SeparateBagsDerivStuff
   f (DerivAuxBind _) = panic "genAuxBinds'" -- We have removed these before
diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs
--- a/compiler/typecheck/TcHsSyn.hs
+++ b/compiler/typecheck/TcHsSyn.hs
@@ -1677,7 +1677,7 @@
          ; return (env1, binds') })
   where
     collect_ev_bndrs :: Bag EvBind -> [EvVar]
-    collect_ev_bndrs = foldrBag add []
+    collect_ev_bndrs = foldr add []
     add (EvBind { eb_lhs = var }) vars = var : vars
 
 zonkEvBind :: ZonkEnv -> EvBind -> TcM EvBind
diff --git a/compiler/typecheck/TcInteract.hs b/compiler/typecheck/TcInteract.hs
--- a/compiler/typecheck/TcInteract.hs
+++ b/compiler/typecheck/TcInteract.hs
@@ -223,7 +223,7 @@
 
 solveSimples cts
   = {-# SCC "solveSimples" #-}
-    do { updWorkListTcS (\wl -> foldrBag extendWorkListCt wl cts)
+    do { updWorkListTcS (\wl -> foldr extendWorkListCt wl cts)
        ; solve_loop }
   where
     solve_loop
diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs
--- a/compiler/typecheck/TcRnDriver.hs
+++ b/compiler/typecheck/TcRnDriver.hs
@@ -1458,7 +1458,7 @@
                           foe_binds
 
             ; fo_gres = fi_gres `unionBags` foe_gres
-            ; fo_fvs = foldrBag (\gre fvs -> fvs `addOneFV` gre_name gre)
+            ; fo_fvs = foldr (\gre fvs -> fvs `addOneFV` gre_name gre)
                                 emptyFVs fo_gres
 
             ; sig_names = mkNameSet (collectHsValBinders hs_val_binds)
diff --git a/compiler/typecheck/TcSMonad.hs b/compiler/typecheck/TcSMonad.hs
--- a/compiler/typecheck/TcSMonad.hs
+++ b/compiler/typecheck/TcSMonad.hs
@@ -1668,7 +1668,7 @@
     -- constraints, which perhaps may have become soluble after new_tv
     -- is substituted; ditto the dictionaries, which may include (a~b)
     -- or (a~~b) constraints.
-    kicked_out = foldrBag extendWorkListCt
+    kicked_out = foldr extendWorkListCt
                           (emptyWorkList { wl_eqs    = tv_eqs_out
                                          , wl_funeqs = feqs_out })
                           ((dicts_out `andCts` irs_out)
@@ -2054,7 +2054,7 @@
 getNoGivenEqs tclvl skol_tvs
   = do { inerts@(IC { inert_eqs = ieqs, inert_irreds = irreds })
               <- getInertCans
-       ; let has_given_eqs = foldrBag ((||) . ct_given_here) False irreds
+       ; let has_given_eqs = foldr ((||) . ct_given_here) False irreds
                           || anyDVarEnv eqs_given_here ieqs
              insols = filterBag insolubleEqCt irreds
                       -- Specifically includes ones that originated in some
@@ -2317,7 +2317,7 @@
 ********************************************************************* -}
 
 foldIrreds :: (Ct -> b -> b) -> Cts -> b -> b
-foldIrreds k irreds z = foldrBag k z irreds
+foldIrreds k irreds z = foldr k z irreds
 
 
 {- *********************************************************************
@@ -2467,7 +2467,7 @@
 
 addDictsByClass :: DictMap Ct -> Class -> Bag Ct -> DictMap Ct
 addDictsByClass m cls items
-  = addToUDFM m cls (foldrBag add emptyTM items)
+  = addToUDFM m cls (foldr add emptyTM items)
   where
     add ct@(CDictCan { cc_tyargs = tys }) tm = insertTM tys ct tm
     add ct _ = pprPanic "addDictsByClass" (ppr ct)
diff --git a/compiler/typecheck/TcSigs.hs b/compiler/typecheck/TcSigs.hs
--- a/compiler/typecheck/TcSigs.hs
+++ b/compiler/typecheck/TcSigs.hs
@@ -45,7 +45,6 @@
 import Id       ( Id, idName, idType, idInlinePragma, setInlinePragma, mkLocalId )
 import PrelNames( mkUnboundName )
 import BasicTypes
-import Bag( foldrBag )
 import Module( getModule )
 import Name
 import NameEnv
@@ -577,7 +576,7 @@
 
     -- ar_env maps a local to the arity of its definition
     ar_env :: NameEnv Arity
-    ar_env = foldrBag lhsBindArity emptyNameEnv binds
+    ar_env = foldr lhsBindArity emptyNameEnv binds
 
 lhsBindArity :: LHsBind GhcRn -> NameEnv Arity -> NameEnv Arity
 lhsBindArity (L _ (FunBind { fun_id = id, fun_matches = ms })) env
diff --git a/compiler/typecheck/TcSimplify.hs b/compiler/typecheck/TcSimplify.hs
--- a/compiler/typecheck/TcSimplify.hs
+++ b/compiler/typecheck/TcSimplify.hs
@@ -48,7 +48,6 @@
 import TcRnMonad as TcM
 import TcSMonad  as TcS
 import TcType
-import TrieMap       () -- DV: for now
 import Type
 import TysWiredIn    ( liftedRepTy )
 import Unify         ( tcMatchTyKi )
@@ -1850,7 +1849,7 @@
  = do { ev_binds <- TcS.getTcEvBindsMap ev_binds_var
       ; tcvs     <- TcS.getTcEvTyCoVars ev_binds_var
 
-      ; let seeds1        = foldrBag add_implic_seeds old_needs implics
+      ; let seeds1        = foldr add_implic_seeds old_needs implics
             seeds2        = foldEvBindMap add_wanted seeds1 ev_binds
             seeds3        = seeds2 `unionVarSet` tcvs
             need_inner    = findNeededEvVars ev_binds seeds3
@@ -2128,7 +2127,7 @@
         new_trapping_tvs = trapping_tvs `extendVarSetList` ic_skols imp
 
     do_bag :: (a -> Bag c) -> Bag a -> Bag c
-    do_bag f = foldrBag (unionBags.f) emptyBag
+    do_bag f = foldr (unionBags.f) emptyBag
 
     is_floatable skol_tvs ct
        | isGivenCt ct     = False
@@ -2369,7 +2368,7 @@
 
              seed_skols = mkVarSet skols     `unionVarSet`
                           mkVarSet given_ids `unionVarSet`
-                          foldrBag add_non_flt_ct emptyVarSet no_float_cts `unionVarSet`
+                          foldr add_non_flt_ct emptyVarSet no_float_cts `unionVarSet`
                           foldEvBindMap add_one_bind emptyVarSet binds
              -- seed_skols: See Note [What prevents a constraint from floating] (1,2,3)
              -- Include the EvIds of any non-floating constraints
@@ -2408,7 +2407,7 @@
       | otherwise      = not (ctEvId ct `elemVarSet` skols)
 
     add_captured_ev_ids :: Cts -> VarSet -> VarSet
-    add_captured_ev_ids cts skols = foldrBag extra_skol emptyVarSet cts
+    add_captured_ev_ids cts skols = foldr extra_skol emptyVarSet cts
        where
          extra_skol ct acc
            | isDerivedCt ct                           = acc
diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs
--- a/compiler/typecheck/TcTyClsDecls.hs
+++ b/compiler/typecheck/TcTyClsDecls.hs
@@ -1938,11 +1938,12 @@
   ; let (_, final_res_kind) = splitPiTys res_kind
   ; checkDataKindSig DataFamilySort final_res_kind
   ; tc_rep_name <- newTyConRepName tc_name
-  ; let tycon = mkFamilyTyCon tc_name binders
+  ; let inj   = Injective $ replicate (length binders) True
+        tycon = mkFamilyTyCon tc_name binders
                               res_kind
                               (resultVariableName sig)
                               (DataFamilyTyCon tc_rep_name)
-                              parent NotInjective
+                              parent inj
   ; return tycon }
 
   | OpenTypeFamily <- fam_info
diff --git a/compiler/utils/Stream.hs b/compiler/utils/Stream.hs
--- a/compiler/utils/Stream.hs
+++ b/compiler/utils/Stream.hs
@@ -7,8 +7,8 @@
 -- -----------------------------------------------------------------------------
 module Stream (
     Stream(..), yield, liftIO,
-    collect, fromList,
-    Stream.map, Stream.mapM, Stream.mapAccumL
+    collect, collect_, consume, fromList,
+    Stream.map, Stream.mapM, Stream.mapAccumL, Stream.mapAccumL_
   ) where
 
 import GhcPrelude
@@ -71,6 +71,25 @@
       Left () -> return (reverse acc)
       Right (a, str') -> go str' (a:acc)
 
+-- | Turn a Stream into an ordinary list, by demanding all the elements.
+collect_ :: Monad m => Stream m a r -> m ([a], r)
+collect_ str = go str []
+ where
+  go str acc = do
+    r <- runStream str
+    case r of
+      Left r -> return (reverse acc, r)
+      Right (a, str') -> go str' (a:acc)
+
+consume :: Monad m => Stream m a b -> (a -> m ()) -> m b
+consume str f = do
+    r <- runStream str
+    case r of
+      Left ret -> return ret
+      Right (a, str') -> do
+        f a
+        consume str' f
+
 -- | Turn a list into a 'Stream', by yielding each element in turn.
 fromList :: Monad m => [a] -> Stream m a ()
 fromList = mapM_ yield
@@ -104,3 +123,13 @@
     Right (a, str') -> do
       (c',b) <- f c a
       return (Right (b, mapAccumL f c' str'))
+
+mapAccumL_ :: Monad m => (c -> a -> m (c,b)) -> c -> Stream m a r
+           -> Stream m b (c, r)
+mapAccumL_ f c str = Stream $ do
+  r <- runStream str
+  case r of
+    Left  r -> return (Left (c, r))
+    Right (a, str') -> do
+      (c',b) <- f c a
+      return (Right (b, mapAccumL_ f c' str'))
diff --git a/ghc-lib.cabal b/ghc-lib.cabal
--- a/ghc-lib.cabal
+++ b/ghc-lib.cabal
@@ -1,7 +1,7 @@
 cabal-version: >=1.22
 build-type: Simple
 name: ghc-lib
-version: 0.20190806
+version: 0.20190903
 license: BSD3
 license-file: LICENSE
 category: Development
@@ -85,7 +85,7 @@
         transformers == 0.5.*,
         process >= 1 && < 1.7,
         hpc == 0.6.*,
-        ghc-lib-parser == 0.20190806
+        ghc-lib-parser == 0.20190903
     build-tools: alex >= 3.1, happy >= 1.19.4
     other-extensions:
         BangPatterns
@@ -121,8 +121,6 @@
         UnboxedTuples
         UndecidableInstances
     hs-source-dirs:
-        ghc-lib/stage0/libraries/ghci/build
-        ghc-lib/stage0/compiler/build
         ghc-lib/stage1/compiler/build
         libraries/template-haskell
         compiler/specialise
diff --git a/ghc-lib/generated/ghcversion.h b/ghc-lib/generated/ghcversion.h
--- a/ghc-lib/generated/ghcversion.h
+++ b/ghc-lib/generated/ghcversion.h
@@ -6,7 +6,7 @@
 #endif
 
 #define __GLASGOW_HASKELL_PATCHLEVEL1__ 0
-#define __GLASGOW_HASKELL_PATCHLEVEL2__ 20190804
+#define __GLASGOW_HASKELL_PATCHLEVEL2__ 20190902
 
 #define MIN_VERSION_GLASGOW_HASKELL(ma,mi,pl1,pl2) (\
    ((ma)*100+(mi)) <  __GLASGOW_HASKELL__ || \
diff --git a/ghc-lib/stage0/libraries/ghci/build/GHCi/InfoTable.hs b/ghc-lib/stage0/libraries/ghci/build/GHCi/InfoTable.hs
deleted file mode 100644
--- a/ghc-lib/stage0/libraries/ghci/build/GHCi/InfoTable.hs
+++ /dev/null
@@ -1,377 +0,0 @@
-{-# LINE 1 "libraries/ghci/GHCi/InfoTable.hsc" #-}
-{-# LANGUAGE CPP, MagicHash, ScopedTypeVariables #-}
-
--- Get definitions for the structs, constants & config etc.
-
-
--- |
--- Run-time info table support.  This module provides support for
--- creating and reading info tables /in the running program/.
--- We use the RTS data structures directly via hsc2hs.
---
-module GHCi.InfoTable
-  (
-
-{-# LINE 14 "libraries/ghci/GHCi/InfoTable.hsc" #-}
-    mkConInfoTable
-
-{-# LINE 16 "libraries/ghci/GHCi/InfoTable.hsc" #-}
-  ) where
-
-import Prelude -- See note [Why do we import Prelude here?]
-
-{-# LINE 20 "libraries/ghci/GHCi/InfoTable.hsc" #-}
-import Foreign
-import Foreign.C
-import GHC.Ptr
-import GHC.Exts
-import GHC.Exts.Heap
-import Data.ByteString (ByteString)
-import qualified Data.ByteString as BS
-
-{-# LINE 28 "libraries/ghci/GHCi/InfoTable.hsc" #-}
-
-ghciTablesNextToCode :: Bool
-
-{-# LINE 31 "libraries/ghci/GHCi/InfoTable.hsc" #-}
-ghciTablesNextToCode = True
-
-{-# LINE 35 "libraries/ghci/GHCi/InfoTable.hsc" #-}
-
-
-{-# LINE 37 "libraries/ghci/GHCi/InfoTable.hsc" #-}
--- NOTE: Must return a pointer acceptable for use in the header of a closure.
--- If tables_next_to_code is enabled, then it must point the the 'code' field.
--- Otherwise, it should point to the start of the StgInfoTable.
-mkConInfoTable
-   :: Int     -- ptr words
-   -> Int     -- non-ptr words
-   -> Int     -- constr tag
-   -> Int     -- pointer tag
-   -> ByteString  -- con desc
-   -> IO (Ptr StgInfoTable)
-      -- resulting info table is allocated with allocateExec(), and
-      -- should be freed with freeExec().
-
-mkConInfoTable ptr_words nonptr_words tag ptrtag con_desc =
-  castFunPtrToPtr <$> newExecConItbl itbl con_desc
-  where
-     entry_addr = interpConstrEntry !! ptrtag
-     code' = mkJumpToAddr entry_addr
-     itbl  = StgInfoTable {
-                 entry = if ghciTablesNextToCode
-                         then Nothing
-                         else Just entry_addr,
-                 ptrs  = fromIntegral ptr_words,
-                 nptrs = fromIntegral nonptr_words,
-                 tipe  = CONSTR,
-                 srtlen = fromIntegral tag,
-                 code  = if ghciTablesNextToCode
-                         then Just code'
-                         else Nothing
-              }
-
-
--- -----------------------------------------------------------------------------
--- Building machine code fragments for a constructor's entry code
-
-funPtrToInt :: FunPtr a -> Int
-funPtrToInt (FunPtr a) = I# (addr2Int# a)
-
-data Arch = ArchSPARC
-          | ArchPPC
-          | ArchX86
-          | ArchX86_64
-          | ArchAlpha
-          | ArchARM
-          | ArchARM64
-          | ArchPPC64
-          | ArchPPC64LE
-          | ArchUnknown
- deriving Show
-
-platform :: Arch
-platform =
-
-{-# LINE 96 "libraries/ghci/GHCi/InfoTable.hsc" #-}
-       ArchX86_64
-
-{-# LINE 114 "libraries/ghci/GHCi/InfoTable.hsc" #-}
-
-mkJumpToAddr :: EntryFunPtr -> ItblCodes
-mkJumpToAddr a = case platform of
-    ArchSPARC ->
-        -- After some consideration, we'll try this, where
-        -- 0x55555555 stands in for the address to jump to.
-        -- According to includes/rts/MachRegs.h, %g3 is very
-        -- likely indeed to be baggable.
-        --
-        --   0000 07155555              sethi   %hi(0x55555555), %g3
-        --   0004 8610E155              or      %g3, %lo(0x55555555), %g3
-        --   0008 81C0C000              jmp     %g3
-        --   000c 01000000              nop
-
-        let w32 = fromIntegral (funPtrToInt a)
-
-            hi22, lo10 :: Word32 -> Word32
-            lo10 x = x .&. 0x3FF
-            hi22 x = (x `shiftR` 10) .&. 0x3FFFF
-
-        in Right [ 0x07000000 .|. (hi22 w32),
-                   0x8610E000 .|. (lo10 w32),
-                   0x81C0C000,
-                   0x01000000 ]
-
-    ArchPPC ->
-        -- We'll use r12, for no particular reason.
-        -- 0xDEADBEEF stands for the address:
-        -- 3D80DEAD lis r12,0xDEAD
-        -- 618CBEEF ori r12,r12,0xBEEF
-        -- 7D8903A6 mtctr r12
-        -- 4E800420 bctr
-
-        let w32 = fromIntegral (funPtrToInt a)
-            hi16 x = (x `shiftR` 16) .&. 0xFFFF
-            lo16 x = x .&. 0xFFFF
-        in Right [ 0x3D800000 .|. hi16 w32,
-                   0x618C0000 .|. lo16 w32,
-                   0x7D8903A6, 0x4E800420 ]
-
-    ArchX86 ->
-        -- Let the address to jump to be 0xWWXXYYZZ.
-        -- Generate   movl $0xWWXXYYZZ,%eax  ;  jmp *%eax
-        -- which is
-        -- B8 ZZ YY XX WW FF E0
-
-        let w32 = fromIntegral (funPtrToInt a) :: Word32
-            insnBytes :: [Word8]
-            insnBytes
-               = [0xB8, byte0 w32, byte1 w32,
-                        byte2 w32, byte3 w32,
-                  0xFF, 0xE0]
-        in
-            Left insnBytes
-
-    ArchX86_64 ->
-        -- Generates:
-        --      jmpq *.L1(%rip)
-        --      .align 8
-        -- .L1:
-        --      .quad <addr>
-        --
-        -- which looks like:
-        --     8:   ff 25 02 00 00 00     jmpq   *0x2(%rip)      # 10 <f+0x10>
-        -- with addr at 10.
-        --
-        -- We need a full 64-bit pointer (we can't assume the info table is
-        -- allocated in low memory).  Assuming the info pointer is aligned to
-        -- an 8-byte boundary, the addr will also be aligned.
-
-        let w64 = fromIntegral (funPtrToInt a) :: Word64
-            insnBytes :: [Word8]
-            insnBytes
-               = [0xff, 0x25, 0x02, 0x00, 0x00, 0x00, 0x00, 0x00,
-                  byte0 w64, byte1 w64, byte2 w64, byte3 w64,
-                  byte4 w64, byte5 w64, byte6 w64, byte7 w64]
-        in
-            Left insnBytes
-
-    ArchAlpha ->
-        let w64 = fromIntegral (funPtrToInt a) :: Word64
-        in Right [ 0xc3800000      -- br   at, .+4
-                 , 0xa79c000c      -- ldq  at, 12(at)
-                 , 0x6bfc0000      -- jmp  (at)    # with zero hint -- oh well
-                 , 0x47ff041f      -- nop
-                 , fromIntegral (w64 .&. 0x0000FFFF)
-                 , fromIntegral ((w64 `shiftR` 32) .&. 0x0000FFFF) ]
-
-    ArchARM { } ->
-        -- Generates Arm sequence,
-        --      ldr r1, [pc, #0]
-        --      bx r1
-        --
-        -- which looks like:
-        --     00000000 <.addr-0x8>:
-        --     0:       00109fe5    ldr    r1, [pc]      ; 8 <.addr>
-        --     4:       11ff2fe1    bx     r1
-        let w32 = fromIntegral (funPtrToInt a) :: Word32
-        in Left [ 0x00, 0x10, 0x9f, 0xe5
-                , 0x11, 0xff, 0x2f, 0xe1
-                , byte0 w32, byte1 w32, byte2 w32, byte3 w32]
-
-    ArchARM64 { } ->
-        -- Generates:
-        --
-        --      ldr     x1, label
-        --      br      x1
-        -- label:
-        --      .quad <addr>
-        --
-        -- which looks like:
-        --     0:       58000041        ldr     x1, <label>
-        --     4:       d61f0020        br      x1
-       let w64 = fromIntegral (funPtrToInt a) :: Word64
-       in Right [ 0x58000041
-                , 0xd61f0020
-                , fromIntegral w64
-                , fromIntegral (w64 `shiftR` 32) ]
-    ArchPPC64 ->
-        -- We use the compiler's register r12 to read the function
-        -- descriptor and the linker's register r11 as a temporary
-        -- register to hold the function entry point.
-        -- In the medium code model the function descriptor
-        -- is located in the first two gigabytes, i.e. the address
-        -- of the function pointer is a non-negative 32 bit number.
-        -- 0x0EADBEEF stands for the address of the function pointer:
-        --    0:   3d 80 0e ad     lis     r12,0x0EAD
-        --    4:   61 8c be ef     ori     r12,r12,0xBEEF
-        --    8:   e9 6c 00 00     ld      r11,0(r12)
-        --    c:   e8 4c 00 08     ld      r2,8(r12)
-        --   10:   7d 69 03 a6     mtctr   r11
-        --   14:   e9 6c 00 10     ld      r11,16(r12)
-        --   18:   4e 80 04 20     bctr
-       let  w32 = fromIntegral (funPtrToInt a)
-            hi16 x = (x `shiftR` 16) .&. 0xFFFF
-            lo16 x = x .&. 0xFFFF
-       in Right [ 0x3D800000 .|. hi16 w32,
-                  0x618C0000 .|. lo16 w32,
-                  0xE96C0000,
-                  0xE84C0008,
-                  0x7D6903A6,
-                  0xE96C0010,
-                  0x4E800420]
-
-    ArchPPC64LE ->
-        -- The ABI requires r12 to point to the function's entry point.
-        -- We use the medium code model where code resides in the first
-        -- two gigabytes, so loading a non-negative32 bit address
-        -- with lis followed by ori is fine.
-        -- 0x0EADBEEF stands for the address:
-        -- 3D800EAD lis r12,0x0EAD
-        -- 618CBEEF ori r12,r12,0xBEEF
-        -- 7D8903A6 mtctr r12
-        -- 4E800420 bctr
-
-        let w32 = fromIntegral (funPtrToInt a)
-            hi16 x = (x `shiftR` 16) .&. 0xFFFF
-            lo16 x = x .&. 0xFFFF
-        in Right [ 0x3D800000 .|. hi16 w32,
-                   0x618C0000 .|. lo16 w32,
-                   0x7D8903A6, 0x4E800420 ]
-
-    -- This code must not be called. You either need to
-    -- add your architecture as a distinct case or
-    -- use non-TABLES_NEXT_TO_CODE mode
-    ArchUnknown -> error "mkJumpToAddr: ArchUnknown is unsupported"
-
-byte0 :: (Integral w) => w -> Word8
-byte0 w = fromIntegral w
-
-byte1, byte2, byte3, byte4, byte5, byte6, byte7
-       :: (Integral w, Bits w) => w -> Word8
-byte1 w = fromIntegral (w `shiftR` 8)
-byte2 w = fromIntegral (w `shiftR` 16)
-byte3 w = fromIntegral (w `shiftR` 24)
-byte4 w = fromIntegral (w `shiftR` 32)
-byte5 w = fromIntegral (w `shiftR` 40)
-byte6 w = fromIntegral (w `shiftR` 48)
-byte7 w = fromIntegral (w `shiftR` 56)
-
-
--- -----------------------------------------------------------------------------
--- read & write intfo tables
-
--- entry point for direct returns for created constr itbls
-foreign import ccall "&stg_interp_constr1_entry" stg_interp_constr1_entry :: EntryFunPtr
-foreign import ccall "&stg_interp_constr2_entry" stg_interp_constr2_entry :: EntryFunPtr
-foreign import ccall "&stg_interp_constr3_entry" stg_interp_constr3_entry :: EntryFunPtr
-foreign import ccall "&stg_interp_constr4_entry" stg_interp_constr4_entry :: EntryFunPtr
-foreign import ccall "&stg_interp_constr5_entry" stg_interp_constr5_entry :: EntryFunPtr
-foreign import ccall "&stg_interp_constr6_entry" stg_interp_constr6_entry :: EntryFunPtr
-foreign import ccall "&stg_interp_constr7_entry" stg_interp_constr7_entry :: EntryFunPtr
-
-interpConstrEntry :: [EntryFunPtr]
-interpConstrEntry = [ error "pointer tag 0"
-                    , stg_interp_constr1_entry
-                    , stg_interp_constr2_entry
-                    , stg_interp_constr3_entry
-                    , stg_interp_constr4_entry
-                    , stg_interp_constr5_entry
-                    , stg_interp_constr6_entry
-                    , stg_interp_constr7_entry ]
-
-data StgConInfoTable = StgConInfoTable {
-   conDesc   :: Ptr Word8,
-   infoTable :: StgInfoTable
-}
-
-
-pokeConItbl
-  :: Ptr StgConInfoTable -> Ptr StgConInfoTable -> StgConInfoTable
-  -> IO ()
-pokeConItbl wr_ptr _ex_ptr itbl = do
-
-{-# LINE 328 "libraries/ghci/GHCi/InfoTable.hsc" #-}
-  -- Write the offset to the con_desc from the end of the standard InfoTable
-  -- at the first byte.
-  let con_desc_offset = conDesc itbl `minusPtr` (_ex_ptr `plusPtr` conInfoTableSizeB)
-  ((\hsc_ptr -> pokeByteOff hsc_ptr 0)) wr_ptr con_desc_offset
-{-# LINE 332 "libraries/ghci/GHCi/InfoTable.hsc" #-}
-
-{-# LINE 338 "libraries/ghci/GHCi/InfoTable.hsc" #-}
-  pokeItbl (wr_ptr `plusPtr` ((8))) (infoTable itbl)
-{-# LINE 339 "libraries/ghci/GHCi/InfoTable.hsc" #-}
-
-sizeOfEntryCode :: Int
-sizeOfEntryCode
-  | not ghciTablesNextToCode = 0
-  | otherwise =
-     case mkJumpToAddr undefined of
-       Left  xs -> sizeOf (head xs) * length xs
-       Right xs -> sizeOf (head xs) * length xs
-
--- Note: Must return proper pointer for use in a closure
-newExecConItbl :: StgInfoTable -> ByteString -> IO (FunPtr ())
-newExecConItbl obj con_desc
-   = alloca $ \pcode -> do
-        let lcon_desc = BS.length con_desc + 1{- null terminator -}
-            -- SCARY
-            -- This size represents the number of bytes in an StgConInfoTable.
-            sz = fromIntegral (conInfoTableSizeB + sizeOfEntryCode)
-               -- Note: we need to allocate the conDesc string next to the info
-               -- table, because on a 64-bit platform we reference this string
-               -- with a 32-bit offset relative to the info table, so if we
-               -- allocated the string separately it might be out of range.
-        wr_ptr <- _allocateExec (sz + fromIntegral lcon_desc) pcode
-        ex_ptr <- peek pcode
-        let cinfo = StgConInfoTable { conDesc = ex_ptr `plusPtr` fromIntegral sz
-                                    , infoTable = obj }
-        pokeConItbl wr_ptr ex_ptr cinfo
-        BS.useAsCStringLen con_desc $ \(src, len) ->
-            copyBytes (castPtr wr_ptr `plusPtr` fromIntegral sz) src len
-        let null_off = fromIntegral sz + fromIntegral (BS.length con_desc)
-        poke (castPtr wr_ptr `plusPtr` null_off) (0 :: Word8)
-        _flushExec sz ex_ptr -- Cache flush (if needed)
-
-{-# LINE 371 "libraries/ghci/GHCi/InfoTable.hsc" #-}
-        return (castPtrToFunPtr (ex_ptr `plusPtr` conInfoTableSizeB))
-
-{-# LINE 375 "libraries/ghci/GHCi/InfoTable.hsc" #-}
-
-foreign import ccall unsafe "allocateExec"
-  _allocateExec :: CUInt -> Ptr (Ptr a) -> IO (Ptr a)
-
-foreign import ccall unsafe "flushExec"
-  _flushExec :: CUInt -> Ptr a -> IO ()
-
--- -----------------------------------------------------------------------------
--- Constants and config
-
-wORD_SIZE :: Int
-wORD_SIZE = (8)
-{-# LINE 387 "libraries/ghci/GHCi/InfoTable.hsc" #-}
-
-conInfoTableSizeB :: Int
-conInfoTableSizeB = wORD_SIZE + itblSize
-
-{-# LINE 391 "libraries/ghci/GHCi/InfoTable.hsc" #-}